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
16
17
18
			  ArithSeqInfo, Stmt, Fake )
import RnHsSyn		( RenamedPat(..) )
import TcHsSyn		( TcPat(..), TcIdOcc(..) )

19
import TcMonad		hiding ( rnMtoTcM )
20
21
22
23
import Inst		( Inst, OverloadedLit(..), InstOrigin(..),
			  emptyLIE, plusLIE, plusLIEs, LIE(..),
			  newMethod, newOverloadedLit
			)
24
import TcEnv		( tcLookupGlobalValue, tcLookupGlobalValueByKey, 
25
			  tcLookupLocalValueOK )
26
import TcType 		( 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
import RnHsSyn		( RnName{-instance Outputable-} )
38
39
import Type		( splitFunTy, splitRhoTy, splitSigmaTy, mkTyVarTys,
			  getFunTy_maybe, maybeAppDataTyCon,
40
			  SYN_IE(Type), GenType
41
			)
42
import TyVar		( GenTyVar )
43
44
45
46
import TysPrim		( charPrimTy, intPrimTy, floatPrimTy,
			  doublePrimTy, addrPrimTy
			)
import TysWiredIn	( charTy, stringTy, mkListTy, mkTupleTy, addrTy )
47
import Unique		( Unique, eqClassOpKey )
48
import Util		( assertPanic, panic{-ToDo:rm-} )
49
\end{code}
50
51

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

\begin{code}
tcPat pat_in@(RecPatIn name rpats)
196
197
  = tcLookupGlobalValue name		`thenNF_Tc` \ con_id ->
    tcInstId con_id			`thenNF_Tc` \ (_, _, con_tau) ->
198
199
200
201
202
203
204
    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
205
    ASSERT( maybeToBool (maybeAppDataTyCon record_ty) )
206
207
208

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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


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

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

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])
364
\end{code}