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

\begin{code}
#include "HsVersions.h"

9
10
module TcPat ( tcPat ) where

11
IMP_Ubiq(){-uitous-}
12
13

import HsSyn		( InPat(..), OutPat(..), HsExpr(..), HsLit(..),
14
			  Match, HsBinds, Qualifier, PolyType,
15
			  ArithSeqInfo, Stmt, Fake )
16
17
import RnHsSyn		( SYN_IE(RenamedPat), RnName{-instance Outputable-} )
import TcHsSyn		( SYN_IE(TcPat), TcIdOcc(..) )
18

19
import TcMonad		hiding ( rnMtoTcM )
20
import Inst		( Inst, OverloadedLit(..), InstOrigin(..),
21
			  emptyLIE, plusLIE, plusLIEs, SYN_IE(LIE),
22
23
			  newMethod, newOverloadedLit
			)
24
import TcEnv		( tcLookupGlobalValue, tcLookupGlobalValueByKey, 
25
			  tcLookupLocalValueOK )
26
import TcType 		( SYN_IE(TcType), TcMaybe, newTyVarTy, newTyVarTys, tcInstId )
27
28
29
30
31
32
import Unify 		( unifyTauTy, unifyTauTyList, unifyTauTyLists )

import Bag		( Bag )
import CmdLineOpts	( opt_IrrefutableTuples )
import Id		( GenId, idType )
import Kind		( Kind, mkBoxedTypeKind, mkTypeKind )
33
import Maybes		( maybeToBool )
34
import PprType		( GenType, GenTyVar )
35
import PprStyle--ToDo:rm
36
import Pretty
37
38
import Type		( splitFunTy, splitRhoTy, splitSigmaTy, mkTyVarTys,
			  getFunTy_maybe, maybeAppDataTyCon,
39
			  SYN_IE(Type), GenType
40
			)
41
import TyVar		( GenTyVar )
42
43
44
45
import TysPrim		( charPrimTy, intPrimTy, floatPrimTy,
			  doublePrimTy, addrPrimTy
			)
import TysWiredIn	( charTy, stringTy, mkListTy, mkTupleTy, addrTy )
46
import Unique		( Unique, eqClassOpKey )
47
import Util		( assertPanic, panic{-ToDo:rm-} )
48
\end{code}
49
50

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

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

\begin{code}
61
tcPat (VarPatIn name)
62
  = tcLookupLocalValueOK ("tcPat1:"++ppShow 80 (ppr PprDebug name)) name	`thenNF_Tc` \ id ->
63
    returnTc (VarPat (TcId id), emptyLIE, idType id)
64

65
66
tcPat (LazyPatIn pat)
  = tcPat pat		`thenTc` \ (pat', lie, ty) ->
67
68
    returnTc (LazyPat pat', lie, ty)

69
70
71
72
73
74
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)
75

76
tcPat WildPatIn
77
78
  = newTyVarTy mkTypeKind	`thenNF_Tc` \ tyvar_ty ->
    returnTc (WildPat tyvar_ty, emptyLIE, tyvar_ty)
79

80
81
82
83
84
85
86
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"

87
88
tcPat (ParPatIn parend_pat)
  = tcPat parend_pat
89
90
91
92
93
94
95
96
97
\end{code}

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

\begin{code}
98
99
100
101
102
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_`
103
104
105

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

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

112
113
	-- Make sure we record that the tuples can only contain boxed types
    newTyVarTys arity mkBoxedTypeKind  	`thenNF_Tc` \ tyvar_tys ->
114

115
116
    tcAddErrCtxt (patCtxt pat_in)	$
    unifyTauTyLists tyvar_tys tys	`thenTc_`
117
118
119
120
121
122
123
124
125

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

127
	possibly_mangled_result
128
	  = if opt_IrrefutableTuples
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
162
163
164
	    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}
165
tcPat pat_in@(ConPatIn name pats)
166
  = tcPats pats				`thenTc` \ (pats', lie, tys) ->
167

168
    tcAddErrCtxt (patCtxt pat_in)	$
169
    matchConArgTys name tys 		`thenTc` \ (con_id, data_ty) ->
170

171
172
173
174
    returnTc (ConPat con_id data_ty pats', 
	      lie, 
	      data_ty)

175
tcPat pat_in@(ConOpPatIn pat1 op pat2) 	-- in binary-op form...
176
  = tcPat pat1				`thenTc` \ (pat1', lie1, ty1) ->
177
    tcPat pat2				`thenTc` \ (pat2', lie2, ty2) ->
178

179
    tcAddErrCtxt (patCtxt pat_in)	$
180
    matchConArgTys op [ty1,ty2]	`thenTc` \ (con_id, data_ty) ->
181
182
183
184

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

187
188
189
190
191
192
193
194
%************************************************************************
%*									*
\subsection{Records}
%*									*
%************************************************************************

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

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

208
    returnTc (RecPat con_id record_ty rpats', 
209
	      plusLIEs lies, 
210
	      record_ty)
211
212
213

  where
    do_bind expected_record_ty (field_label, rhs_pat, pun_flag)
214
215
      = tcLookupGlobalValue field_label		`thenNF_Tc` \ sel_id ->
	tcInstId sel_id				`thenNF_Tc` \ (_, _, tau) ->
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233

		-- Record selectors all have type
		-- 	forall a1..an.  T a1 .. an -> tau
	ASSERT( maybeToBool (getFunTy_maybe tau) )
	let
		-- Selector must have type RecordType -> FieldType
	  Just (record_ty, field_ty) = getFunTy_maybe tau
	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}

234
235
236
237
238
239
240
%************************************************************************
%*									*
\subsection{Non-overloaded literals}
%*									*
%************************************************************************

\begin{code}
241
242
tcPat (LitPatIn lit@(HsChar str))
  = returnTc (LitPat lit charTy, emptyLIE, charTy)
243

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

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

\begin{code}
272
273
274
275
tcPat (LitPatIn lit@(HsInt i))
  = newTyVarTy mkBoxedTypeKind				`thenNF_Tc` \ tyvar_ty ->
    newOverloadedLit origin  
		     (OverloadedIntegral i) tyvar_ty	`thenNF_Tc` \ (lie1, over_lit_id) ->
276

277
278
    tcLookupGlobalValueByKey eqClassOpKey		`thenNF_Tc` \ eq_sel_id ->
    newMethod origin (RealId eq_sel_id) [tyvar_ty]	`thenNF_Tc` \ (lie2, eq_id) ->
279

280
281
282
    returnTc (NPat lit tyvar_ty (HsApp (HsVar eq_id)
				       (HsVar over_lit_id)),
	      lie1 `plusLIE` lie2,
283
	      tyvar_ty)
284
285
  where
    origin = LiteralOrigin lit
286

287
288
tcPat (LitPatIn lit@(HsFrac f))
  = newTyVarTy mkBoxedTypeKind				`thenNF_Tc` \ tyvar_ty ->
289
    newOverloadedLit origin
290
		     (OverloadedFractional f) tyvar_ty	`thenNF_Tc` \ (lie1, over_lit_id) ->
291

292
293
    tcLookupGlobalValueByKey eqClassOpKey		`thenNF_Tc` \ eq_sel_id ->
    newMethod origin (RealId eq_sel_id) [tyvar_ty]	`thenNF_Tc` \ (lie2, eq_id) ->
294

295
296
297
    returnTc (NPat lit tyvar_ty (HsApp (HsVar eq_id)
				       (HsVar over_lit_id)),
	      lie1 `plusLIE` lie2,
298
	      tyvar_ty)
299
300
  where
    origin = LiteralOrigin lit
301

302
tcPat (LitPatIn lit@(HsLitLit s))
303
304
305
306
307
308
309
310
311
312
  = error "tcPat: can't handle ``literal-literal'' patterns"
\end{code}

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

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

315
tcPats [] = returnTc ([], emptyLIE, [])
316

317
318
319
tcPats (pat:pats)
  = tcPat pat		`thenTc` \ (pat',  lie,  ty)  ->
    tcPats pats		`thenTc` \ (pats', lie', tys) ->
320
321
322
323
324
325
326
327

    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}
328
matchConArgTys :: RnName -> [TcType s] -> TcM s (Id, TcType s)
329

330
matchConArgTys con arg_tys
331
332
  = tcLookupGlobalValue con		`thenNF_Tc` \ con_id ->
    tcInstId con_id			`thenNF_Tc` \ (_, _, con_tau) ->
333
	     -- Ignore the con_theta; overloaded constructors only
334
335
	     -- behave differently when called, not when used for
	     -- matching.
336
    let
337
338
	(con_args, con_result) = splitFunTy con_tau
	con_arity  = length con_args
339
	no_of_args = length arg_tys
340
    in
341
342
    checkTc (con_arity == no_of_args)
	    (arityErr "Constructor" con_id con_arity no_of_args)	`thenTc_`
343

344
    unifyTauTyLists arg_tys con_args	 				`thenTc_`
345
    returnTc (con_id, con_result)
346
347
348
349
350
351
352
353
354
\end{code}


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

Errors and contexts
~~~~~~~~~~~~~~~~~~~
\begin{code}
patCtxt pat sty = ppHang (ppStr "In the pattern:") 4 (ppr sty pat)
355
356
357
358
359
360
361
362

recordLabel field_label sty
  = ppHang (ppBesides [ppStr "When matching record field", ppr sty field_label])
	 4 (ppBesides [ppStr "with its immediately enclosing constructor"])

recordRhs field_label pat sty
  = ppHang (ppStr "In the record field pattern")
	 4 (ppSep [ppr sty field_label, ppStr "=", ppr sty pat])
363
\end{code}