TcPat.lhs 10.8 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
11
12
13
14
15
16
17
18
19
module TcPat ( tcPat ) where

import Ubiq{-uitous-}

import HsSyn		( InPat(..), OutPat(..), HsExpr(..), HsLit(..),
			  Match, HsBinds, Qual, PolyType,
			  ArithSeqInfo, Stmt, Fake )
import RnHsSyn		( RenamedPat(..) )
import TcHsSyn		( TcPat(..), TcIdOcc(..) )

import TcMonad
20
21
22
23
import Inst		( Inst, OverloadedLit(..), InstOrigin(..),
			  emptyLIE, plusLIE, plusLIEs, LIE(..),
			  newMethod, newOverloadedLit
			)
24
import TcEnv		( tcLookupGlobalValue, tcLookupGlobalValueByKey, 
25
			  tcLookupLocalValueOK, tcGlobalOcc )
26
27
28
29
30
31
32
import TcType 		( TcType(..), TcMaybe, tcInstType, newTyVarTy, newTyVarTys )
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
35
36
import Name		( Name )
import PprType		( GenType, GenTyVar )
import PrelInfo		( charPrimTy, intPrimTy, floatPrimTy,
37
			  doublePrimTy, charTy, stringTy, mkListTy,
38
39
			  mkTupleTy, addrTy, addrPrimTy )
import Pretty
40
41
42
43
import Type		( splitFunTy, splitRhoTy, splitSigmaTy, mkTyVarTys,
			  getFunTy_maybe, maybeAppDataTyCon,
			  Type(..), GenType
			)
44
45
import TyVar		( GenTyVar )
import Unique		( Unique, eqClassOpKey )
46
import Util		( assertPanic, panic{-ToDo:rm-} )
47
\end{code}
48
49

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

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

\begin{code}
60
61
62
tcPat (VarPatIn name)
  = tcLookupLocalValueOK "tcPat1" name	`thenNF_Tc` \ id ->
    returnTc (VarPat (TcId id), emptyLIE, idType id)
63

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

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

75
76
77
tcPat (WildPatIn)
  = newTyVarTy mkTypeKind	`thenNF_Tc` \ tyvar_ty ->
    returnTc (WildPat tyvar_ty, emptyLIE, tyvar_ty)
78
79
80
81
82
83
84
85
86
\end{code}

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

\begin{code}
87
88
89
90
91
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_`
92
93
94

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

95
tcPat pat_in@(TuplePatIn pats)
96
97
98
  = let
	arity = length pats
    in
99
    tcPats pats   			`thenTc` \ (pats', lie, tys) ->
100

101
102
	-- Make sure we record that the tuples can only contain boxed types
    newTyVarTys arity mkBoxedTypeKind  	`thenNF_Tc` \ tyvar_tys ->
103

104
105
    tcAddErrCtxt (patCtxt pat_in)	$
    unifyTauTyLists tyvar_tys tys	`thenTc_`
106
107
108
109
110
111
112
113
114

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

116
	possibly_mangled_result
117
	  = if opt_IrrefutableTuples
118
119
120
121
122
123
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
	    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}
154
tcPat pat_in@(ConPatIn name pats)
155
  = tcPats pats				`thenTc` \ (pats', lie, tys) ->
156

157
    tcAddErrCtxt (patCtxt pat_in)	$
158
    matchConArgTys name tys 		`thenTc` \ (con_id, data_ty) ->
159

160
161
162
163
164
    returnTc (ConPat con_id data_ty pats', 
	      lie, 
	      data_ty)

tcPat pat_in@(ConOpPatIn pat1 op pat2) -- & in binary-op form...
165
  = tcPat pat1				`thenTc` \ (pat1', lie1, ty1) ->
166
    tcPat pat2				`thenTc` \ (pat2', lie2, ty2) ->
167

168
    tcAddErrCtxt (patCtxt pat_in)	$
169
    matchConArgTys op [ty1,ty2]	`thenTc` \ (con_id, data_ty) ->
170
171
172
173

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

176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
%************************************************************************
%*									*
\subsection{Records}
%*									*
%************************************************************************

\begin{code}
tcPat pat_in@(RecPatIn name rpats)
  = tcGlobalOcc name		`thenNF_Tc` \ (con_id, _, con_rho) ->
    let
	(_, con_tau) = splitRhoTy con_rho
	     -- 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
    ASSERT( maybeToBool (maybeAppDataTyCon record_ty ) )

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

    returnTc (panic "tcPat:RecPatIn:avoid type errors"{-RecPat con_id record_ty rpats', 
	      plusLIEs lies, 
	      record_ty-})

  where
    do_bind expected_record_ty (field_label, rhs_pat, pun_flag)
      = tcGlobalOcc field_label		`thenNF_Tc` \ (sel_id, _, tau) ->

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

222
223
224
225
226
227
228
%************************************************************************
%*									*
\subsection{Non-overloaded literals}
%*									*
%************************************************************************

\begin{code}
229
230
tcPat (LitPatIn lit@(HsChar str))
  = returnTc (LitPat lit charTy, emptyLIE, charTy)
231

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

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

\begin{code}
260
261
262
263
tcPat (LitPatIn lit@(HsInt i))
  = newTyVarTy mkBoxedTypeKind				`thenNF_Tc` \ tyvar_ty ->
    newOverloadedLit origin  
		     (OverloadedIntegral i) tyvar_ty	`thenNF_Tc` \ (lie1, over_lit_id) ->
264

265
266
    tcLookupGlobalValueByKey eqClassOpKey		`thenNF_Tc` \ eq_sel_id ->
    newMethod origin (RealId eq_sel_id) [tyvar_ty]	`thenNF_Tc` \ (lie2, eq_id) ->
267

268
269
270
    returnTc (NPat lit tyvar_ty (HsApp (HsVar eq_id)
				       (HsVar over_lit_id)),
	      lie1 `plusLIE` lie2,
271
	      tyvar_ty)
272
273
  where
    origin = LiteralOrigin lit
274

275
276
tcPat (LitPatIn lit@(HsFrac f))
  = newTyVarTy mkBoxedTypeKind				`thenNF_Tc` \ tyvar_ty ->
277
    newOverloadedLit origin
278
		     (OverloadedFractional f) tyvar_ty	`thenNF_Tc` \ (lie1, over_lit_id) ->
279

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

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

290
tcPat (LitPatIn lit@(HsLitLit s))
291
292
293
294
295
296
297
298
299
300
  = error "tcPat: can't handle ``literal-literal'' patterns"
\end{code}

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

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

303
tcPats [] = returnTc ([], emptyLIE, [])
304

305
306
307
tcPats (pat:pats)
  = tcPat pat		`thenTc` \ (pat',  lie,  ty)  ->
    tcPats pats		`thenTc` \ (pats', lie', tys) ->
308
309
310
311
312
313
314
315

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

318
319
matchConArgTys con arg_tys
  = tcGlobalOcc con		`thenNF_Tc` \ (con_id, _, con_rho) ->
320
    let
321
322
	(con_theta, con_tau) = splitRhoTy con_rho
	     -- Ignore the con_theta; overloaded constructors only
323
324
	     -- behave differently when called, not when used for
	     -- matching.
325

326
327
	(con_args, con_result) = splitFunTy con_tau
	con_arity  = length con_args
328
	no_of_args = length arg_tys
329
    in
330
331
    checkTc (con_arity == no_of_args)
	    (arityErr "Constructor" con_id con_arity no_of_args)	`thenTc_`
332

333
    unifyTauTyLists arg_tys con_args	 				`thenTc_`
334
    returnTc (con_id, con_result)
335
336
337
338
339
340
341
342
343
\end{code}


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

Errors and contexts
~~~~~~~~~~~~~~~~~~~
\begin{code}
patCtxt pat sty = ppHang (ppStr "In the pattern:") 4 (ppr sty pat)
344
345
346
347
348
349
350
351

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