TcPat.lhs 16.3 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
import HsSyn		( InPat(..), OutPat(..), HsLit(..), HsExpr(..), Sig(..) )
12
import RnHsSyn		( RenamedPat )
13
import TcHsSyn		( TcPat, TcId )
14

15
import TcMonad
16
import Inst		( Inst, OverloadedLit(..), InstOrigin(..),
17
			  emptyLIE, plusLIE, LIE,
18
			  newMethod, newOverloadedLit, newDicts, newClassDicts
19
			)
20
import Name		( Name, getOccName, getSrcLoc )
21
import FieldLabel	( fieldLabelName )
22
import TcEnv		( tcLookupValue, tcLookupClassByKey,
23
			  tcLookupValueByKey, newLocalId, badCon
24
			)
25
import TcType 		( TcType, TcTyVar, tcInstTyVars, newTyVarTy )
26
import TcMonoType	( tcHsSigType )
27
import TcUnify 		( unifyTauTy, unifyListTy, unifyTupleTy	)
28
29

import CmdLineOpts	( opt_IrrefutableTuples )
30
31
32
import DataCon		( DataCon, dataConSig, dataConFieldLabels, 
			  dataConSourceArity
			)
33
import Id		( Id, idType, isDataConWrapId_maybe )
34
35
import Type		( Type, isTauTy, mkTyConApp, mkClassPred, boxedTypeKind )
import Subst		( substTy, substClasses )
36
37
38
import TysPrim		( charPrimTy, intPrimTy, floatPrimTy,
			  doublePrimTy, addrPrimTy
			)
39
import TysWiredIn	( charTy, stringTy, intTy )
40
41
42
import Unique		( eqClassOpKey, geClassOpKey, minusClassOpKey,
			  cCallableClassKey
			)
43
import BasicTypes	( isBoxed )
44
45
import Bag
import Util		( zipEqual )
sof's avatar
sof committed
46
import Outputable
47
\end{code}
48

49
50
51
52
53
54
55
56

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

\begin{code}
57
58
59
60
61
62
-- 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
63
64
 where
   loc = getSrcLoc binder_name
65
66
67
68
69
70
71
72
73
\end{code}


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

74
\begin{code}
75
76
77
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
78
      -> RenamedPat
79
80
81
82
83
84
85

      -> 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

86
87
88
89
90
91
92
      -> 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
93
94
95
					--	which it occurs in the pattern
					-- 	The two aren't the same because we conjure up a new
					-- 	local name for each variable.
96
97
		LIE)			-- Dicts or methods [see below] bound by the pattern
					-- 	from existential constructor patterns
98
99
\end{code}

100

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

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

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

116
117
118
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) ->
119
    tcAddErrCtxt (patCtxt pat_in) 	$
120
121
    returnTc (AsPat bndr_id pat', lie_req, 
	      tvs, (name, bndr_id) `consBag` ids, lie_avail)
122

123
tcPat tc_bndr WildPatIn pat_ty
124
  = returnTc (WildPat pat_ty, emptyLIE, emptyBag, emptyBag, emptyLIE)
125

126
127
tcPat tc_bndr (NegPatIn pat) pat_ty
  = tcPat tc_bndr (negate_lit pat) pat_ty
128
  where
129
130
131
132
133
134
    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"
135

136
137
tcPat tc_bndr (ParPatIn parend_pat) pat_ty
  = tcPat tc_bndr parend_pat pat_ty
138

139
tcPat tc_bndr (SigPatIn pat sig) pat_ty
140
  = tcHsSigType sig					`thenTc` \ sig_ty ->
141
142
143
144
145
146

	-- 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_`
147
    tcPat tc_bndr pat sig_ty
148
149
150
151
152
153
154
155
156
\end{code}

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

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

163
tcPat tc_bndr pat_in@(TuplePatIn pats boxity) pat_ty
164
  = tcAddErrCtxt (patCtxt pat_in)	$
165

166
167
    unifyTupleTy boxity arity pat_ty		`thenTc` \ arg_tys ->
    tcPats tc_bndr pats arg_tys 		`thenTc` \ (pats', lie_req, tvs, ids, lie_avail) ->
168
169
170

	-- possibly do the "make all tuple-pats irrefutable" test:
    let
171
	unmangled_result = TuplePat pats' boxity
172
173
174
175
176

	-- 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.
177

178
	possibly_mangled_result
179
180
	  | opt_IrrefutableTuples && isBoxed boxity = LazyPat unmangled_result
	  | otherwise			   	    = unmangled_result
181
    in
182
183
184
    returnTc (possibly_mangled_result, lie_req, tvs, ids, lie_avail)
  where
    arity = length pats
185
186
187
188
189
190
191
\end{code}

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

192
%************************************************************************
193
194

\begin{code}
195
196
tcPat tc_bndr pat@(ConPatIn name arg_pats) pat_ty
  = tcConPat tc_bndr pat name arg_pats pat_ty
197

198
199
tcPat tc_bndr pat@(ConOpPatIn pat1 op _ pat2) pat_ty
  = tcConPat tc_bndr pat op [pat1, pat2] pat_ty
200
201
\end{code}

202

203
204
205
206
207
208
209
%************************************************************************
%*									*
\subsection{Records}
%*									*
%************************************************************************

\begin{code}
210
tcPat tc_bndr pat@(RecPatIn name rpats) pat_ty
211
  = tcAddErrCtxt (patCtxt pat)	$
212

213
214
215
216
217
218
 	-- 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
219
220
    in

221
222
	-- Check the fields
    tc_fields field_tys rpats		`thenTc` \ (rpats', lie_req, tvs, ids, lie_avail2) ->
223

224
225
226
227
228
    returnTc (RecPat data_con pat_ty ex_tvs dicts rpats',
	      lie_req,
	      listToBag ex_tvs `unionBags` tvs,
	      ids,
	      lie_avail1 `plusLIE` lie_avail2)
229
230

  where
231
232
233
234
    tc_fields field_tys []
      = returnTc ([], emptyLIE, emptyBag, emptyBag, emptyLIE)

    tc_fields field_tys ((field_label, rhs_pat, pun_flag) : rpats)
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
      =	tc_fields field_tys rpats	`thenTc` \ (rpats', lie_req1, tvs1, ids1, lie_avail1) ->

	(case [ty | (f,ty) <- field_tys, f == field_label] of

		-- No matching field; chances are this field label comes from some
		-- other record type (or maybe none).  As well as reporting an
		-- error we still want to typecheck the pattern, principally to
		-- make sure that all the variables it binds are put into the
		-- environment, else the type checker crashes later:
		--	f (R { foo = (a,b) }) = a+b
		-- If foo isn't one of R's fields, we don't want to crash when
		-- typechecking the "a+b".
	   [] -> addErrTc (badFieldCon name field_label)	`thenNF_Tc_` 
		 newTyVarTy boxedTypeKind			`thenNF_Tc_` 
		 returnTc (error "Bogus selector Id", pat_ty)

		-- The normal case, when the field comes from the right constructor
	   (pat_ty : extras) -> 
		ASSERT( null extras )
		tcLookupValue field_label			`thenNF_Tc` \ sel_id ->
		returnTc (sel_id, pat_ty)
	)							`thenTc` \ (sel_id, pat_ty) ->

	tcPat tc_bndr rhs_pat pat_ty	`thenTc` \ (rhs_pat', lie_req2, tvs2, ids2, lie_avail2) ->
259
260
261
262
263
264

	returnTc ((sel_id, rhs_pat', pun_flag) : rpats',
		  lie_req1 `plusLIE` lie_req2,
		  tvs1 `unionBags` tvs2,
		  ids1 `unionBags` ids2,
		  lie_avail1 `plusLIE` lie_avail2)
265
266
\end{code}

267
268
269
270
271
272
273
%************************************************************************
%*									*
\subsection{Non-overloaded literals}
%*									*
%************************************************************************

\begin{code}
274
275
276
277
278
279
280
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

281
282
283
284
tcPat tc_bndr (LitPatIn lit@(HsLitLit s))     pat_ty 
	-- cf tcExpr on LitLits
  = tcLookupClassByKey cCallableClassKey		`thenNF_Tc` \ cCallableClass ->
    newDicts (LitLitOrigin (_UNPK_ s))
285
	     [mkClassPred cCallableClass [pat_ty]]	`thenNF_Tc` \ (dicts, _) ->
286
    returnTc (LitPat lit pat_ty, dicts, emptyBag, emptyBag, emptyLIE)
287
288
289
290
291
292
293
294
295
\end{code}

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

\begin{code}
296
tcPat tc_bndr pat@(LitPatIn lit@(HsString str)) pat_ty
297
  = unifyTauTy pat_ty stringTy			`thenTc_` 
298
299
    tcLookupValueByKey eqClassOpKey		`thenNF_Tc` \ sel_id ->
    newMethod (PatOrigin pat) sel_id [stringTy]	`thenNF_Tc` \ (lie, eq_id) ->
300
301
302
303
    let
	comp_op = HsApp (HsVar eq_id) (HsLitOut lit stringTy)
    in
    returnTc (NPat lit stringTy comp_op, lie, emptyBag, emptyBag, emptyLIE)
304
305


306
tcPat tc_bndr pat@(LitPatIn lit@(HsInt i)) pat_ty
307
  = tcOverloadedLitPat pat lit (OverloadedIntegral i) pat_ty
308

309
tcPat tc_bndr pat@(LitPatIn lit@(HsFrac f)) pat_ty
310
  = tcOverloadedLitPat pat lit (OverloadedFractional f) pat_ty
311

312

313
314
tcPat tc_bndr pat@(NPlusKPatIn name lit@(HsInt i)) pat_ty
  = tc_bndr name pat_ty				`thenTc` \ bndr_id ->
315
316
    tcLookupValueByKey geClassOpKey		`thenNF_Tc` \ ge_sel_id ->
    tcLookupValueByKey minusClassOpKey		`thenNF_Tc` \ minus_sel_id ->
317
318

    newOverloadedLit origin
319
		     (OverloadedIntegral i) pat_ty	`thenNF_Tc` \ (over_lit_expr, lie1) ->
320

321
322
    newMethod origin ge_sel_id    [pat_ty]	`thenNF_Tc` \ (lie2, ge_id) ->
    newMethod origin minus_sel_id [pat_ty]	`thenNF_Tc` \ (lie3, minus_id) ->
323

324
    returnTc (NPlusKPat bndr_id lit pat_ty
sof's avatar
sof committed
325
326
			(SectionR (HsVar ge_id) over_lit_expr)
			(SectionR (HsVar minus_id) over_lit_expr),
327
	      lie1 `plusLIE` lie2 `plusLIE` lie3,
328
	      emptyBag, unitBag (name, bndr_id), emptyLIE)
329
  where
330
    origin = PatOrigin pat
331

332
tcPat tc_bndr (NPlusKPatIn pat other) pat_ty
333
  = panic "TcPat:NPlusKPat: not an HsInt literal"
334
335
336
337
338
339
340
341
\end{code}

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

342
343
Helper functions

344
\begin{code}
345
346
tcPats :: (Name -> TcType -> TcM s TcId)	-- How to deal with variables
       -> [RenamedPat] -> [TcType]		-- Excess 'expected types' discarded
347
348
349
350
351
       -> 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
352

353
tcPats tc_bndr [] tys = returnTc ([], emptyLIE, emptyBag, emptyBag, emptyLIE)
354

355
356
357
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) ->
358
359
360
361
362

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

364
365
366
367
368
------------------------------------------------------
\begin{code}
tcSimpleLitPat lit lit_ty pat_ty
  = unifyTauTy pat_ty lit_ty	`thenTc_` 
    returnTc (LitPat lit lit_ty, emptyLIE, emptyBag, emptyBag, emptyLIE)
369
370


371
372
tcOverloadedLitPat pat lit over_lit pat_ty
  = newOverloadedLit (PatOrigin pat) over_lit pat_ty	`thenNF_Tc` \ (over_lit_expr, lie1) ->
373
374
    tcLookupValueByKey eqClassOpKey			`thenNF_Tc` \ eq_sel_id ->
    newMethod origin eq_sel_id [pat_ty]			`thenNF_Tc` \ (lie2, eq_id) ->
375

376
377
378
379
380
381
382
    returnTc (NPat lit pat_ty (HsApp (HsVar eq_id)
				     over_lit_expr),
	      lie1 `plusLIE` lie2,
	      emptyBag, emptyBag, emptyLIE)
  where
    origin = PatOrigin pat
\end{code}
383

384
------------------------------------------------------
385
\begin{code}
386
387
tcConstructor pat con_name pat_ty
  = 	-- Check that it's a constructor
388
    tcLookupValue con_name		`thenNF_Tc` \ con_id ->
389
    case isDataConWrapId_maybe con_id of {
390
391
392
393
394
395
396
	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
397
398
	     -- behave differently when called, not when used for
	     -- matching.
399
400
401
    in
    tcInstTyVars (ex_tvs ++ tvs)	`thenNF_Tc` \ (all_tvs', ty_args', tenv) ->
    let
402
	ex_theta' = substClasses tenv ex_theta
403
	arg_tys'  = map (substTy tenv) arg_tys
404
405
406
407
408

	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
409
    newClassDicts (PatOrigin pat) ex_theta'	`thenNF_Tc` \ (lie_avail, dicts) ->
410
411
412
413
414
415
416
417
418
419

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

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

------------------------------------------------------
\begin{code}
420
tcConPat tc_bndr pat con_name arg_pats pat_ty
421
422
423
424
425
426
  = 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
427
    let
428
429
	con_arity  = dataConSourceArity data_con
	no_of_args = length arg_pats
430
    in
431
    checkTc (con_arity == no_of_args)
432
433
434
	    (arityErr "Constructor" data_con con_arity no_of_args)	`thenTc_`

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

437
438
439
440
441
    returnTc (ConPat data_con pat_ty ex_tvs' dicts arg_pats',
	      lie_req,
	      listToBag ex_tvs' `unionBags` tvs,
	      ids,
	      lie_avail1 `plusLIE` lie_avail2)
442
443
444
\end{code}


445
446
447
448
449
450
%************************************************************************
%*									*
\subsection{Errors and contexts}
%*									*
%************************************************************************

451
\begin{code}
452
453
patCtxt pat = hang (ptext SLIT("In the pattern:")) 
		 4 (ppr pat)
454

455
456
recordLabel field_label
  = hang (hcat [ptext SLIT("When matching record field"), ppr field_label])
sof's avatar
sof committed
457
	 4 (hcat [ptext SLIT("with its immediately enclosing constructor")])
458

459
recordRhs field_label pat
sof's avatar
sof committed
460
  = hang (ptext SLIT("In the record field pattern"))
461
	 4 (sep [ppr field_label, char '=', ppr pat])
462

463
464
badFieldCon :: Name -> Name -> SDoc
badFieldCon con field
465
  = hsep [ptext SLIT("Constructor") <+> quotes (ppr con),
466
	  ptext SLIT("does not have field"), quotes (ppr field)]
467
468
469

polyPatSig :: TcType -> SDoc
polyPatSig sig_ty
470
  = hang (ptext SLIT("Illegal polymorphic type signature in pattern:"))
471
	 4 (ppr sig_ty)
472
\end{code}
473