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

\begin{code}
7
8
module TcPat ( tcPat ) where

9
#include "HsVersions.h"
10

11
12
13
import HsSyn		( InPat(..), OutPat(..), HsLit(..), HsExpr(..) )
import RnHsSyn		( RenamedPat )
import TcHsSyn		( TcPat )
14

15
import TcMonad
16
import Inst		( Inst, OverloadedLit(..), InstOrigin(..),
17
			  emptyLIE, plusLIE, plusLIEs, LIE,
18
19
			  newMethod, newOverloadedLit
			)
20
import Name		( Name {- instance Outputable -} )
21
22
23
24
import TcEnv		( TcIdOcc(..), tcLookupGlobalValue, tcLookupGlobalValueByKey, 
			  tcLookupLocalValueOK, tcInstId
			)
import TcType 		( TcType, TcMaybe, newTyVarTy, newTyVarTys )
25
26
import Unify 		( unifyTauTy, unifyTauTyList, unifyTauTyLists )

27
import Maybes		( maybeToBool )
28
29
import Bag		( Bag )
import CmdLineOpts	( opt_IrrefutableTuples )
30
import Id		( GenId, idType, Id )
31
32
import Kind		( Kind, mkBoxedTypeKind, mkTypeKind )
import PprType		( GenType, GenTyVar )
33
import Type		( splitFunTys, splitRhoTy,
34
			  splitFunTy_maybe, splitAlgTyConApp_maybe,
35
			  Type, GenType
36
			)
37
import TyVar		( GenTyVar )
38
39
40
import TysPrim		( charPrimTy, intPrimTy, floatPrimTy,
			  doublePrimTy, addrPrimTy
			)
41
import TysWiredIn	( charTy, stringTy, mkListTy, mkTupleTy )
42
import Unique		( Unique, eqClassOpKey, geClassOpKey, minusClassOpKey )
43
import Util		( assertPanic, panic )
sof's avatar
sof committed
44
import Outputable
45
\end{code}
46
47

\begin{code}
48
tcPat :: RenamedPat -> TcM s (TcPat s, LIE s, TcType s)
49
50
51
52
53
54
55
56
57
\end{code}

%************************************************************************
%*									*
\subsection{Variables, wildcards, lazy pats, as-pats}
%*									*
%************************************************************************

\begin{code}
58
tcPat (VarPatIn name)
59
  = tcLookupLocalValueOK "tcPat1:" name		`thenNF_Tc` \ id ->
60
    returnTc (VarPat (TcId id), emptyLIE, idType id)
61

62
63
tcPat (LazyPatIn pat)
  = tcPat pat		`thenTc` \ (pat', lie, ty) ->
64
65
    returnTc (LazyPat pat', lie, ty)

66
67
68
69
70
71
tcPat pat_in@(AsPatIn name pat)
  = tcLookupLocalValueOK "tcPat2"  name	`thenNF_Tc` \ id ->
    tcPat pat				`thenTc` \ (pat', lie, ty) ->
    tcAddErrCtxt (patCtxt pat_in) 	$
    unifyTauTy (idType id) ty		`thenTc_`
    returnTc (AsPat (TcId id) pat', lie, ty)
72

73
tcPat WildPatIn
74
75
  = newTyVarTy mkTypeKind	`thenNF_Tc` \ tyvar_ty ->
    returnTc (WildPat tyvar_ty, emptyLIE, tyvar_ty)
76

77
78
79
80
81
82
83
tcPat (NegPatIn pat)
  = tcPat (negate_lit pat)
  where
    negate_lit (LitPatIn (HsInt  i)) = LitPatIn (HsInt  (-i))
    negate_lit (LitPatIn (HsFrac f)) = LitPatIn (HsFrac (-f))
    negate_lit _                     = panic "TcPat:negate_pat"

84
85
tcPat (ParPatIn parend_pat)
  = tcPat parend_pat
86
87
88
89
90
91
92
93
94
\end{code}

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

\begin{code}
95
96
97
98
99
tcPat pat_in@(ListPatIn pats)
  = tcPats pats				`thenTc`    \ (pats', lie, tys) ->
    newTyVarTy mkBoxedTypeKind		`thenNF_Tc` \ tyvar_ty ->
    tcAddErrCtxt (patCtxt pat_in)	$
    unifyTauTyList (tyvar_ty:tys)	`thenTc_`
100
101
102

    returnTc (ListPat tyvar_ty pats', lie, mkListTy tyvar_ty)

103
tcPat pat_in@(TuplePatIn pats)
104
105
106
  = let
	arity = length pats
    in
107
    tcPats pats   			`thenTc` \ (pats', lie, tys) ->
108

109
110
	-- Make sure we record that the tuples can only contain boxed types
    newTyVarTys arity mkBoxedTypeKind  	`thenNF_Tc` \ tyvar_tys ->
111

112
113
    tcAddErrCtxt (patCtxt pat_in)	$
    unifyTauTyLists tyvar_tys tys	`thenTc_`
114
115
116
117
118
119
120
121
122

	-- possibly do the "make all tuple-pats irrefutable" test:
    let
	unmangled_result = TuplePat pats'

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

124
	possibly_mangled_result
125
	  = if opt_IrrefutableTuples
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
	    then LazyPat unmangled_result
	    else unmangled_result

	-- ToDo: IrrefutableEverything
    in
    returnTc (possibly_mangled_result, lie, mkTupleTy arity tys)
\end{code}

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

Constructor patterns are a little fun:
\begin{itemize}
\item
typecheck the arguments
\item
look up the constructor
\item
specialise its type (ignore the translation this produces)
\item
check that the context produced by this specialisation is empty
\item
get the arguments out of the function type produced from specialising
\item
unify them with the types of the patterns
\item
back substitute with the type of the result of the constructor
\end{itemize}

ToDo: exploit new representation of constructors to make this more
efficient?

\begin{code}
162
tcPat pat_in@(ConPatIn name pats)
163
  = tcPats pats				`thenTc` \ (pats', lie, tys) ->
164

165
    tcAddErrCtxt (patCtxt pat_in)	$
166
    matchConArgTys name tys 		`thenTc` \ (con_id, data_ty) ->
167

168
169
170
171
    returnTc (ConPat con_id data_ty pats', 
	      lie, 
	      data_ty)

172
tcPat pat_in@(ConOpPatIn pat1 op _ pat2) 	-- in binary-op form...
173
  = tcPat pat1				`thenTc` \ (pat1', lie1, ty1) ->
174
    tcPat pat2				`thenTc` \ (pat2', lie2, ty2) ->
175

176
    tcAddErrCtxt (patCtxt pat_in)	$
177
    matchConArgTys op [ty1,ty2]	`thenTc` \ (con_id, data_ty) ->
178
179
180
181

    returnTc (ConOpPat pat1' con_id pat2' data_ty, 
	      lie1 `plusLIE` lie2, 
	      data_ty)
182
183
\end{code}

184
185
186
187
188
189
190
191
%************************************************************************
%*									*
\subsection{Records}
%*									*
%************************************************************************

\begin{code}
tcPat pat_in@(RecPatIn name rpats)
192
193
  = tcLookupGlobalValue name		`thenNF_Tc` \ con_id ->
    tcInstId con_id			`thenNF_Tc` \ (_, _, con_tau) ->
194
195
196
197
    let
	     -- Ignore the con_theta; overloaded constructors only
	     -- behave differently when called, not when used for
	     -- matching.
198
	(_, record_ty) = splitFunTys con_tau
199
200
    in
	-- Con is syntactically constrained to be a data constructor
201
    ASSERT( maybeToBool (splitAlgTyConApp_maybe record_ty) )
202
203
204

    mapAndUnzipTc (do_bind record_ty) rpats	`thenTc` \ (rpats', lies) ->

205
    returnTc (RecPat con_id record_ty rpats', 
206
	      plusLIEs lies, 
207
	      record_ty)
208
209
210

  where
    do_bind expected_record_ty (field_label, rhs_pat, pun_flag)
211
212
      = tcLookupGlobalValue field_label		`thenNF_Tc` \ sel_id ->
	tcInstId sel_id				`thenNF_Tc` \ (_, _, tau) ->
213
214
215

		-- Record selectors all have type
		-- 	forall a1..an.  T a1 .. an -> tau
216
	ASSERT( maybeToBool (splitFunTy_maybe tau) )
217
218
	let
		-- Selector must have type RecordType -> FieldType
219
	  Just (record_ty, field_ty) = splitFunTy_maybe tau
220
221
222
223
224
225
226
227
228
229
230
	in
	tcAddErrCtxt (recordLabel field_label) (
	  unifyTauTy expected_record_ty record_ty
	)						`thenTc_`
	tcPat rhs_pat					`thenTc` \ (rhs_pat', lie, rhs_ty) ->
	tcAddErrCtxt (recordRhs field_label rhs_pat) (
	  unifyTauTy field_ty rhs_ty
	)			 			`thenTc_`
	returnTc ((sel_id, rhs_pat', pun_flag), lie)
\end{code}

231
232
233
234
235
236
237
%************************************************************************
%*									*
\subsection{Non-overloaded literals}
%*									*
%************************************************************************

\begin{code}
238
239
tcPat (LitPatIn lit@(HsChar str))
  = returnTc (LitPat lit charTy, emptyLIE, charTy)
240

241
242
243
244
tcPat (LitPatIn lit@(HsString str))
  = tcLookupGlobalValueByKey eqClassOpKey	`thenNF_Tc` \ sel_id ->
    newMethod (LiteralOrigin lit) 
	      (RealId sel_id) [stringTy]	`thenNF_Tc` \ (lie, eq_id) ->
245
    let
246
	comp_op = HsApp (HsVar eq_id) (HsLitOut lit stringTy)
247
    in
248
249
250
251
252
253
254
255
256
257
258
259
    returnTc (NPat lit stringTy comp_op, lie, stringTy)

tcPat (LitPatIn lit@(HsIntPrim _))
  = returnTc (LitPat lit intPrimTy, emptyLIE, intPrimTy)
tcPat (LitPatIn lit@(HsCharPrim _))
  = returnTc (LitPat lit charPrimTy, emptyLIE, charPrimTy)
tcPat (LitPatIn lit@(HsStringPrim _))
  = returnTc (LitPat lit addrPrimTy, emptyLIE, addrPrimTy)
tcPat (LitPatIn lit@(HsFloatPrim _))
  = returnTc (LitPat lit floatPrimTy, emptyLIE, floatPrimTy)
tcPat (LitPatIn lit@(HsDoublePrim _))
  = returnTc (LitPat lit doublePrimTy, emptyLIE, doublePrimTy)
260
261
262
263
264
265
266
267
268
\end{code}

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

\begin{code}
269
270
271
tcPat (LitPatIn lit@(HsInt i))
  = newTyVarTy mkBoxedTypeKind				`thenNF_Tc` \ tyvar_ty ->
    newOverloadedLit origin  
sof's avatar
sof committed
272
		     (OverloadedIntegral i) tyvar_ty	`thenNF_Tc` \ (over_lit_expr, lie1) ->
273

274
275
    tcLookupGlobalValueByKey eqClassOpKey		`thenNF_Tc` \ eq_sel_id ->
    newMethod origin (RealId eq_sel_id) [tyvar_ty]	`thenNF_Tc` \ (lie2, eq_id) ->
276

277
    returnTc (NPat lit tyvar_ty (HsApp (HsVar eq_id)
sof's avatar
sof committed
278
				       over_lit_expr),
279
	      lie1 `plusLIE` lie2,
280
	      tyvar_ty)
281
282
  where
    origin = LiteralOrigin lit
283

284
285
tcPat (LitPatIn lit@(HsFrac f))
  = newTyVarTy mkBoxedTypeKind				`thenNF_Tc` \ tyvar_ty ->
286
    newOverloadedLit origin
sof's avatar
sof committed
287
		     (OverloadedFractional f) tyvar_ty	`thenNF_Tc` \ (over_lit_expr, lie1) ->
288

289
290
    tcLookupGlobalValueByKey eqClassOpKey		`thenNF_Tc` \ eq_sel_id ->
    newMethod origin (RealId eq_sel_id) [tyvar_ty]	`thenNF_Tc` \ (lie2, eq_id) ->
291

292
    returnTc (NPat lit tyvar_ty (HsApp (HsVar eq_id)
sof's avatar
sof committed
293
				       over_lit_expr),
294
	      lie1 `plusLIE` lie2,
295
	      tyvar_ty)
296
297
  where
    origin = LiteralOrigin lit
298

299
tcPat (LitPatIn lit@(HsLitLit s))
300
  = error "tcPat: can't handle ``literal-literal'' patterns"
301
302
303
304
305
306
307
308
309
310

tcPat (NPlusKPatIn name lit@(HsInt i))
  = tcLookupLocalValueOK "tcPat1:n+k" name	`thenNF_Tc` \ local ->
    let
	local_ty = idType local
    in
    tcLookupGlobalValueByKey geClassOpKey		`thenNF_Tc` \ ge_sel_id ->
    tcLookupGlobalValueByKey minusClassOpKey		`thenNF_Tc` \ minus_sel_id ->

    newOverloadedLit origin
sof's avatar
sof committed
311
		     (OverloadedIntegral i) local_ty	`thenNF_Tc` \ (over_lit_expr, lie1) ->
312
313
314
315
316

    newMethod origin (RealId ge_sel_id)    [local_ty]	`thenNF_Tc` \ (lie2, ge_id) ->
    newMethod origin (RealId minus_sel_id) [local_ty]	`thenNF_Tc` \ (lie3, minus_id) ->

    returnTc (NPlusKPat (TcId local) lit local_ty
sof's avatar
sof committed
317
318
			(SectionR (HsVar ge_id) over_lit_expr)
			(SectionR (HsVar minus_id) over_lit_expr),
319
320
321
322
323
324
	      lie1 `plusLIE` lie2 `plusLIE` lie3,
	      local_ty)
  where
    origin = LiteralOrigin lit	-- Not very good!

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

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

\begin{code}
334
tcPats :: [RenamedPat] -> TcM s ([TcPat s], LIE s, [TcType s])
335

336
tcPats [] = returnTc ([], emptyLIE, [])
337

338
339
340
tcPats (pat:pats)
  = tcPat pat		`thenTc` \ (pat',  lie,  ty)  ->
    tcPats pats		`thenTc` \ (pats', lie', tys) ->
341
342
343
344
345
346
347
348

    returnTc (pat':pats', plusLIE lie lie', ty:tys)
\end{code}

@matchConArgTys@ grabs the signature of the data constructor, and
unifies the actual args against the expected ones.

\begin{code}
349
matchConArgTys :: Name -> [TcType s] -> TcM s (Id, TcType s)
350

351
matchConArgTys con arg_tys
352
353
  = tcLookupGlobalValue con		`thenNF_Tc` \ con_id ->
    tcInstId con_id			`thenNF_Tc` \ (_, _, con_tau) ->
354
	     -- Ignore the con_theta; overloaded constructors only
355
356
	     -- behave differently when called, not when used for
	     -- matching.
357
    let
358
	(con_args, con_result) = splitFunTys con_tau
359
	con_arity  = length con_args
360
	no_of_args = length arg_tys
361
    in
362
363
    checkTc (con_arity == no_of_args)
	    (arityErr "Constructor" con_id con_arity no_of_args)	`thenTc_`
364

365
    unifyTauTyLists con_args arg_tys	 				`thenTc_`
366
    returnTc (con_id, con_result)
367
368
369
370
371
372
373
374
\end{code}


% =================================================

Errors and contexts
~~~~~~~~~~~~~~~~~~~
\begin{code}
375
376
patCtxt pat = hang (ptext SLIT("In the pattern:")) 
		 4 (ppr pat)
377

378
379
recordLabel field_label
  = hang (hcat [ptext SLIT("When matching record field"), ppr field_label])
sof's avatar
sof committed
380
	 4 (hcat [ptext SLIT("with its immediately enclosing constructor")])
381

382
recordRhs field_label pat
sof's avatar
sof committed
383
  = hang (ptext SLIT("In the record field pattern"))
384
	 4 (sep [ppr field_label, char '=', ppr pat])
385
\end{code}