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

19
import TcMonad
20
import Inst		( Inst, OverloadedLit(..), InstOrigin(..),
21
			  emptyLIE, plusLIE, plusLIEs, SYN_IE(LIE),
22
23
			  newMethod, newOverloadedLit
			)
24
import Name		( Name {- instance Outputable -} )
25
import TcEnv		( tcLookupGlobalValue, tcLookupGlobalValueByKey, 
26
			  tcLookupLocalValueOK )
27
import SpecEnv		( SpecEnv )
28
import TcType 		( SYN_IE(TcType), TcMaybe, newTyVarTy, newTyVarTys, tcInstId )
29
30
31
32
33
34
import Unify 		( unifyTauTy, unifyTauTyList, unifyTauTyLists )

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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


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

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

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