TcPat.lhs 12.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
15
			  Match, HsBinds, HsType, Fixity,
			  ArithSeqInfo, Stmt, DoOrListComp, 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
import Unify 		( unifyTauTy, unifyTauTyList, unifyTauTyLists )

import Bag		( Bag )
import CmdLineOpts	( opt_IrrefutableTuples )
sof's avatar
sof committed
33
import Id		( GenId, idType, SYN_IE(Id) )
34
import Kind		( Kind, mkBoxedTypeKind, mkTypeKind )
35
import Maybes		( maybeToBool )
36
37
import PprType		( GenType, GenTyVar )
import Pretty
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, geClassOpKey, minusClassOpKey )
48
import Util		( assertPanic, panic )
sof's avatar
sof committed
49
50
51
52

#if __GLASGOW_HASKELL__ >= 202
import Outputable
#endif
53
\end{code}
54
55

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

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

\begin{code}
66
tcPat (VarPatIn name)
sof's avatar
sof committed
67
  = tcLookupLocalValueOK ("tcPat1:"{-++show (ppr PprDebug name)-}) name	`thenNF_Tc` \ id ->
68
    returnTc (VarPat (TcId id), emptyLIE, idType id)
69

70
71
tcPat (LazyPatIn pat)
  = tcPat pat		`thenTc` \ (pat', lie, ty) ->
72
73
    returnTc (LazyPat pat', lie, ty)

74
75
76
77
78
79
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)
80

81
tcPat WildPatIn
82
83
  = newTyVarTy mkTypeKind	`thenNF_Tc` \ tyvar_ty ->
    returnTc (WildPat tyvar_ty, emptyLIE, tyvar_ty)
84

85
86
87
88
89
90
91
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"

92
93
tcPat (ParPatIn parend_pat)
  = tcPat parend_pat
94
95
96
97
98
99
100
101
102
\end{code}

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

\begin{code}
103
104
105
106
107
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_`
108
109
110

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

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

117
118
	-- Make sure we record that the tuples can only contain boxed types
    newTyVarTys arity mkBoxedTypeKind  	`thenNF_Tc` \ tyvar_tys ->
119

120
121
    tcAddErrCtxt (patCtxt pat_in)	$
    unifyTauTyLists tyvar_tys tys	`thenTc_`
122
123
124
125
126
127
128
129
130

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

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

173
    tcAddErrCtxt (patCtxt pat_in)	$
174
    matchConArgTys name tys 		`thenTc` \ (con_id, data_ty) ->
175

176
177
178
179
    returnTc (ConPat con_id data_ty pats', 
	      lie, 
	      data_ty)

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

184
    tcAddErrCtxt (patCtxt pat_in)	$
185
    matchConArgTys op [ty1,ty2]	`thenTc` \ (con_id, data_ty) ->
186
187
188
189

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

192
193
194
195
196
197
198
199
%************************************************************************
%*									*
\subsection{Records}
%*									*
%************************************************************************

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

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

213
    returnTc (RecPat con_id record_ty rpats', 
214
	      plusLIEs lies, 
215
	      record_ty)
216
217
218

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

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

239
240
241
242
243
244
245
%************************************************************************
%*									*
\subsection{Non-overloaded literals}
%*									*
%************************************************************************

\begin{code}
246
247
tcPat (LitPatIn lit@(HsChar str))
  = returnTc (LitPat lit charTy, emptyLIE, charTy)
248

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

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

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

282
283
    tcLookupGlobalValueByKey eqClassOpKey		`thenNF_Tc` \ eq_sel_id ->
    newMethod origin (RealId eq_sel_id) [tyvar_ty]	`thenNF_Tc` \ (lie2, eq_id) ->
284

285
286
287
    returnTc (NPat lit tyvar_ty (HsApp (HsVar eq_id)
				       (HsVar over_lit_id)),
	      lie1 `plusLIE` lie2,
288
	      tyvar_ty)
289
290
  where
    origin = LiteralOrigin lit
291

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

297
298
    tcLookupGlobalValueByKey eqClassOpKey		`thenNF_Tc` \ eq_sel_id ->
    newMethod origin (RealId eq_sel_id) [tyvar_ty]	`thenNF_Tc` \ (lie2, eq_id) ->
299

300
301
302
    returnTc (NPat lit tyvar_ty (HsApp (HsVar eq_id)
				       (HsVar over_lit_id)),
	      lie1 `plusLIE` lie2,
303
	      tyvar_ty)
304
305
  where
    origin = LiteralOrigin lit
306

307
tcPat (LitPatIn lit@(HsLitLit s))
308
  = error "tcPat: can't handle ``literal-literal'' patterns"
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332

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
		     (OverloadedIntegral i) local_ty	`thenNF_Tc` \ (lie1, over_lit_id) ->

    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
			(SectionR (HsVar ge_id) (HsVar over_lit_id))
			(SectionR (HsVar minus_id) (HsVar over_lit_id)),
	      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"
333
334
335
336
337
338
339
340
341
\end{code}

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

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

344
tcPats [] = returnTc ([], emptyLIE, [])
345

346
347
348
tcPats (pat:pats)
  = tcPat pat		`thenTc` \ (pat',  lie,  ty)  ->
    tcPats pats		`thenTc` \ (pats', lie', tys) ->
349
350
351
352
353
354
355
356

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

359
matchConArgTys con arg_tys
360
361
  = tcLookupGlobalValue con		`thenNF_Tc` \ con_id ->
    tcInstId con_id			`thenNF_Tc` \ (_, _, con_tau) ->
362
	     -- Ignore the con_theta; overloaded constructors only
363
364
	     -- behave differently when called, not when used for
	     -- matching.
365
    let
366
367
	(con_args, con_result) = splitFunTy con_tau
	con_arity  = length con_args
368
	no_of_args = length arg_tys
369
    in
370
371
    checkTc (con_arity == no_of_args)
	    (arityErr "Constructor" con_id con_arity no_of_args)	`thenTc_`
372

373
    unifyTauTyLists con_args arg_tys	 				`thenTc_`
374
    returnTc (con_id, con_result)
375
376
377
378
379
380
381
382
\end{code}


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

Errors and contexts
~~~~~~~~~~~~~~~~~~~
\begin{code}
sof's avatar
sof committed
383
patCtxt pat sty = hang (ptext SLIT("In the pattern:")) 4 (ppr sty pat)
384
385

recordLabel field_label sty
sof's avatar
sof committed
386
387
  = hang (hcat [ptext SLIT("When matching record field"), ppr sty field_label])
	 4 (hcat [ptext SLIT("with its immediately enclosing constructor")])
388
389

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