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
import Kind		( Kind, mkBoxedTypeKind, mkTypeKind )
32
import Type		( splitFunTys, splitRhoTy,
33
			  splitFunTy_maybe, splitAlgTyConApp_maybe,
34
			  Type
35
			)
36
37
38
import TysPrim		( charPrimTy, intPrimTy, floatPrimTy,
			  doublePrimTy, addrPrimTy
			)
39
import TysWiredIn	( charTy, stringTy, mkListTy, mkTupleTy, intTy )
40
import Unique		( Unique, eqClassOpKey, geClassOpKey, minusClassOpKey )
41
import Util		( assertPanic, panic )
sof's avatar
sof committed
42
import Outputable
43
\end{code}
44
45

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

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

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

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

64
65
66
67
68
69
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)
70

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

75
76
77
78
79
80
81
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"

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

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

\begin{code}
93
94
95
96
97
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_`
98
99
100

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

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

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

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

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

122
	possibly_mangled_result
123
	  = if opt_IrrefutableTuples
124
125
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
	    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}
160
tcPat pat_in@(ConPatIn name pats)
161
  = tcPats pats				`thenTc` \ (pats', lie, tys) ->
162

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

166
167
168
169
    returnTc (ConPat con_id data_ty pats', 
	      lie, 
	      data_ty)

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

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

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

182
183
184
185
186
187
188
189
%************************************************************************
%*									*
\subsection{Records}
%*									*
%************************************************************************

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

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

203
    returnTc (RecPat con_id record_ty rpats', 
204
	      plusLIEs lies, 
205
	      record_ty)
206
207
208

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

		-- Record selectors all have type
		-- 	forall a1..an.  T a1 .. an -> tau
214
	ASSERT( maybeToBool (splitFunTy_maybe tau) )
215
216
	let
		-- Selector must have type RecordType -> FieldType
217
	  Just (record_ty, field_ty) = splitFunTy_maybe tau
218
219
220
221
222
223
224
225
226
227
228
	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}

229
230
231
232
233
234
235
%************************************************************************
%*									*
\subsection{Non-overloaded literals}
%*									*
%************************************************************************

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

239
240
241
242
tcPat (LitPatIn lit@(HsString str))
  = tcLookupGlobalValueByKey eqClassOpKey	`thenNF_Tc` \ sel_id ->
    newMethod (LiteralOrigin lit) 
	      (RealId sel_id) [stringTy]	`thenNF_Tc` \ (lie, eq_id) ->
243
    let
244
	comp_op = HsApp (HsVar eq_id) (HsLitOut lit stringTy)
245
    in
246
247
248
249
250
251
252
253
254
255
256
257
    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)
258
259
260
261
262
263
264
265
266
\end{code}

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

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

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

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

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

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

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

297
tcPat (LitPatIn lit@(HsLitLit s))
298
299
--  = error "tcPat: can't handle ``literal-literal'' patterns"
  = returnTc (LitPat lit intTy, emptyLIE, intTy)
300
301
302
303
304
305
306
307
308
309

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
310
		     (OverloadedIntegral i) local_ty	`thenNF_Tc` \ (over_lit_expr, lie1) ->
311
312
313
314
315

    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
316
317
			(SectionR (HsVar ge_id) over_lit_expr)
			(SectionR (HsVar minus_id) over_lit_expr),
318
319
320
321
322
323
	      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"
324
325
326
327
328
329
330
331
332
\end{code}

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

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

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

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

    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}
348
matchConArgTys :: Name -> [TcType s] -> TcM s (Id, TcType s)
349

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

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


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

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

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

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