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
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
import TcEnv		( tcLookupValue, tcLookupClassByKey,
26
			  tcLookupValueByKey, newLocalId, badCon
27
			)
28
import TcType 		( TcType, TcTyVar, tcInstTyVars, newTyVarTy )
29
import TcMonoType	( tcHsType )
30
31
32
import TcUnify 		( unifyTauTy, unifyListTy,
			  unifyTupleTy, unifyUnboxedTupleTy
			)
33
34
35

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

55
56
57
58
59
60
61
62

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

\begin{code}
63
64
65
66
67
68
-- 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
69
70
 where
   loc = getSrcLoc binder_name
71
72
73
74
75
76
77
78
79
\end{code}


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

80
\begin{code}
81
82
83
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
84
      -> RenamedPat
85
86
87
88
89
90
91

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

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

106

107
108
109
110
111
112
113
%************************************************************************
%*									*
\subsection{Variables, wildcards, lazy pats, as-pats}
%*									*
%************************************************************************

\begin{code}
114
115
tcPat tc_bndr (VarPatIn name) pat_ty
  = tc_bndr name pat_ty		`thenTc` \ bndr_id ->
116
    returnTc (VarPat bndr_id, emptyLIE, emptyBag, unitBag (name, bndr_id), emptyLIE)
117

118
119
tcPat tc_bndr (LazyPatIn pat) pat_ty
  = tcPat tc_bndr pat pat_ty		`thenTc` \ (pat', lie_req, tvs, ids, lie_avail) ->
120
    returnTc (LazyPat pat', lie_req, tvs, ids, lie_avail)
121

122
123
124
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) ->
125
    tcAddErrCtxt (patCtxt pat_in) 	$
126
127
    returnTc (AsPat bndr_id pat', lie_req, 
	      tvs, (name, bndr_id) `consBag` ids, lie_avail)
128

129
tcPat tc_bndr WildPatIn pat_ty
130
  = returnTc (WildPat pat_ty, emptyLIE, emptyBag, emptyBag, emptyLIE)
131

132
133
tcPat tc_bndr (NegPatIn pat) pat_ty
  = tcPat tc_bndr (negate_lit pat) pat_ty
134
  where
135
136
137
138
139
140
    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"
141

142
143
tcPat tc_bndr (ParPatIn parend_pat) pat_ty
  = tcPat tc_bndr parend_pat pat_ty
144

145
tcPat tc_bndr (SigPatIn pat sig) pat_ty
146
147
148
149
150
151
152
  = 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_`
153
    tcPat tc_bndr pat sig_ty
154
155
156
157
158
159
160
161
162
\end{code}

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

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

169
tcPat tc_bndr pat_in@(TuplePatIn pats boxed) pat_ty
170
  = tcAddErrCtxt (patCtxt pat_in)	$
171

172
173
174
    (if boxed
     then unifyTupleTy        arity pat_ty
     else unifyUnboxedTupleTy arity pat_ty)	`thenTc` \ arg_tys ->
175

176
    tcPats tc_bndr pats arg_tys 	 		`thenTc` \ (pats', lie_req, tvs, ids, lie_avail) ->
177
178
179

	-- possibly do the "make all tuple-pats irrefutable" test:
    let
180
	unmangled_result = TuplePat pats' boxed
181
182
183
184
185

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

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

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

201
%************************************************************************
202
203

\begin{code}
204
205
tcPat tc_bndr pat@(ConPatIn name arg_pats) pat_ty
  = tcConPat tc_bndr pat name arg_pats pat_ty
206

207
208
tcPat tc_bndr pat@(ConOpPatIn pat1 op _ pat2) pat_ty
  = tcConPat tc_bndr pat op [pat1, pat2] pat_ty
209
210
\end{code}

211

212
213
214
215
216
217
218
%************************************************************************
%*									*
\subsection{Records}
%*									*
%************************************************************************

\begin{code}
219
tcPat tc_bndr pat@(RecPatIn name rpats) pat_ty
220
  = tcAddErrCtxt (patCtxt pat)	$
221

222
223
224
225
226
227
 	-- 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
228
229
    in

230
231
	-- Check the fields
    tc_fields field_tys rpats		`thenTc` \ (rpats', lie_req, tvs, ids, lie_avail2) ->
232

233
234
235
236
237
    returnTc (RecPat data_con pat_ty ex_tvs dicts rpats',
	      lie_req,
	      listToBag ex_tvs `unionBags` tvs,
	      ids,
	      lie_avail1 `plusLIE` lie_avail2)
238
239

  where
240
241
242
243
    tc_fields field_tys []
      = returnTc ([], emptyLIE, emptyBag, emptyBag, emptyLIE)

    tc_fields field_tys ((field_label, rhs_pat, pun_flag) : rpats)
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
      =	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) ->
268
269
270
271
272
273

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

276
277
278
279
280
281
282
%************************************************************************
%*									*
\subsection{Non-overloaded literals}
%*									*
%************************************************************************

\begin{code}
283
284
285
286
287
288
289
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

290
291
292
293
294
295
tcPat tc_bndr (LitPatIn lit@(HsLitLit s))     pat_ty 
	-- cf tcExpr on LitLits
  = tcLookupClassByKey cCallableClassKey		`thenNF_Tc` \ cCallableClass ->
    newDicts (LitLitOrigin (_UNPK_ s))
	     [(cCallableClass, [pat_ty])]		`thenNF_Tc` \ (dicts, _) ->
    returnTc (LitPat lit pat_ty, dicts, emptyBag, emptyBag, emptyLIE)
296
297
298
299
300
301
302
303
304
\end{code}

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

\begin{code}
305
tcPat tc_bndr pat@(LitPatIn lit@(HsString str)) pat_ty
306
  = unifyTauTy pat_ty stringTy			`thenTc_` 
307
308
    tcLookupValueByKey eqClassOpKey		`thenNF_Tc` \ sel_id ->
    newMethod (PatOrigin pat) sel_id [stringTy]	`thenNF_Tc` \ (lie, eq_id) ->
309
310
311
312
    let
	comp_op = HsApp (HsVar eq_id) (HsLitOut lit stringTy)
    in
    returnTc (NPat lit stringTy comp_op, lie, emptyBag, emptyBag, emptyLIE)
313
314


315
tcPat tc_bndr pat@(LitPatIn lit@(HsInt i)) pat_ty
316
  = tcOverloadedLitPat pat lit (OverloadedIntegral i) pat_ty
317

318
tcPat tc_bndr pat@(LitPatIn lit@(HsFrac f)) pat_ty
319
  = tcOverloadedLitPat pat lit (OverloadedFractional f) pat_ty
320

321

322
323
tcPat tc_bndr pat@(NPlusKPatIn name lit@(HsInt i)) pat_ty
  = tc_bndr name pat_ty				`thenTc` \ bndr_id ->
324
325
    tcLookupValueByKey geClassOpKey		`thenNF_Tc` \ ge_sel_id ->
    tcLookupValueByKey minusClassOpKey		`thenNF_Tc` \ minus_sel_id ->
326
327

    newOverloadedLit origin
328
		     (OverloadedIntegral i) pat_ty	`thenNF_Tc` \ (over_lit_expr, lie1) ->
329

330
331
    newMethod origin ge_sel_id    [pat_ty]	`thenNF_Tc` \ (lie2, ge_id) ->
    newMethod origin minus_sel_id [pat_ty]	`thenNF_Tc` \ (lie3, minus_id) ->
332

333
    returnTc (NPlusKPat bndr_id lit pat_ty
sof's avatar
sof committed
334
335
			(SectionR (HsVar ge_id) over_lit_expr)
			(SectionR (HsVar minus_id) over_lit_expr),
336
	      lie1 `plusLIE` lie2 `plusLIE` lie3,
337
	      emptyBag, unitBag (name, bndr_id), emptyLIE)
338
  where
339
    origin = PatOrigin pat
340

341
tcPat tc_bndr (NPlusKPatIn pat other) pat_ty
342
  = panic "TcPat:NPlusKPat: not an HsInt literal"
343
344
345
346
347
348
349
350
\end{code}

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

351
352
Helper functions

353
\begin{code}
354
355
tcPats :: (Name -> TcType -> TcM s TcId)	-- How to deal with variables
       -> [RenamedPat] -> [TcType]		-- Excess 'expected types' discarded
356
357
358
359
360
       -> 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
361

362
tcPats tc_bndr [] tys = returnTc ([], emptyLIE, emptyBag, emptyBag, emptyLIE)
363

364
365
366
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) ->
367
368
369
370
371

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

373
374
375
376
377
------------------------------------------------------
\begin{code}
tcSimpleLitPat lit lit_ty pat_ty
  = unifyTauTy pat_ty lit_ty	`thenTc_` 
    returnTc (LitPat lit lit_ty, emptyLIE, emptyBag, emptyBag, emptyLIE)
378
379


380
381
tcOverloadedLitPat pat lit over_lit pat_ty
  = newOverloadedLit (PatOrigin pat) over_lit pat_ty	`thenNF_Tc` \ (over_lit_expr, lie1) ->
382
383
    tcLookupValueByKey eqClassOpKey			`thenNF_Tc` \ eq_sel_id ->
    newMethod origin eq_sel_id [pat_ty]			`thenNF_Tc` \ (lie2, eq_id) ->
384

385
386
387
388
389
390
391
    returnTc (NPat lit pat_ty (HsApp (HsVar eq_id)
				     over_lit_expr),
	      lie1 `plusLIE` lie2,
	      emptyBag, emptyBag, emptyLIE)
  where
    origin = PatOrigin pat
\end{code}
392

393
------------------------------------------------------
394
\begin{code}
395
396
tcConstructor pat con_name pat_ty
  = 	-- Check that it's a constructor
397
    tcLookupValue con_name		`thenNF_Tc` \ con_id ->
398
399
400
401
402
403
404
405
    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
406
407
	     -- behave differently when called, not when used for
	     -- matching.
408
409
410
    in
    tcInstTyVars (ex_tvs ++ tvs)	`thenNF_Tc` \ (all_tvs', ty_args', tenv) ->
    let
411
412
	ex_theta' = substTheta tenv ex_theta
	arg_tys'  = map (substTy tenv) arg_tys
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428

	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}
429
tcConPat tc_bndr pat con_name arg_pats pat_ty
430
431
432
433
434
435
  = 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
436
    let
437
438
	con_arity  = dataConSourceArity data_con
	no_of_args = length arg_pats
439
    in
440
    checkTc (con_arity == no_of_args)
441
442
443
	    (arityErr "Constructor" data_con con_arity no_of_args)	`thenTc_`

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

446
447
448
449
450
    returnTc (ConPat data_con pat_ty ex_tvs' dicts arg_pats',
	      lie_req,
	      listToBag ex_tvs' `unionBags` tvs,
	      ids,
	      lie_avail1 `plusLIE` lie_avail2)
451
452
453
\end{code}


454
455
456
457
458
459
%************************************************************************
%*									*
\subsection{Errors and contexts}
%*									*
%************************************************************************

460
\begin{code}
461
462
patCtxt pat = hang (ptext SLIT("In the pattern:")) 
		 4 (ppr pat)
463

464
465
recordLabel field_label
  = hang (hcat [ptext SLIT("When matching record field"), ppr field_label])
sof's avatar
sof committed
466
	 4 (hcat [ptext SLIT("with its immediately enclosing constructor")])
467

468
recordRhs field_label pat
sof's avatar
sof committed
469
  = hang (ptext SLIT("In the record field pattern"))
470
	 4 (sep [ppr field_label, char '=', ppr pat])
471

472
473
badFieldCon :: Name -> Name -> SDoc
badFieldCon con field
474
  = hsep [ptext SLIT("Constructor") <+> quotes (ppr con),
475
	  ptext SLIT("does not have field"), quotes (ppr field)]
476
477
478
479
480

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