2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[TcPat]{Typechecking patterns}
7 module TcPat ( tcPat ) where
9 #include "HsVersions.h"
11 import HsSyn ( InPat(..), OutPat(..), HsLit(..), HsExpr(..) )
12 import RnHsSyn ( RenamedPat )
13 import TcHsSyn ( TcPat )
16 import Inst ( Inst, OverloadedLit(..), InstOrigin(..),
17 emptyLIE, plusLIE, plusLIEs, LIE,
18 newMethod, newOverloadedLit
20 import Name ( Name {- instance Outputable -} )
21 import TcEnv ( TcIdOcc(..), tcLookupGlobalValue, tcLookupGlobalValueByKey,
22 tcLookupLocalValueOK, tcInstId
24 import TcType ( TcType, TcMaybe, newTyVarTy, newTyVarTys )
25 import Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists )
27 import Maybes ( maybeToBool )
29 import CmdLineOpts ( opt_IrrefutableTuples )
30 import Id ( GenId, idType, Id )
31 import Kind ( Kind, mkBoxedTypeKind, mkTypeKind )
32 import PprType ( GenType, GenTyVar )
33 import Type ( splitFunTys, splitRhoTy,
34 splitFunTy_maybe, splitAlgTyConApp_maybe,
37 import TyVar ( GenTyVar )
38 import TysPrim ( charPrimTy, intPrimTy, floatPrimTy,
39 doublePrimTy, addrPrimTy
41 import TysWiredIn ( charTy, stringTy, mkListTy, mkTupleTy )
42 import Unique ( Unique, eqClassOpKey, geClassOpKey, minusClassOpKey )
43 import Util ( assertPanic, panic )
48 tcPat :: RenamedPat -> TcM s (TcPat s, LIE s, TcType s)
51 %************************************************************************
53 \subsection{Variables, wildcards, lazy pats, as-pats}
55 %************************************************************************
59 = tcLookupLocalValueOK "tcPat1:" name `thenNF_Tc` \ id ->
60 returnTc (VarPat (TcId id), emptyLIE, idType id)
63 = tcPat pat `thenTc` \ (pat', lie, ty) ->
64 returnTc (LazyPat pat', lie, ty)
66 tcPat pat_in@(AsPatIn name pat)
67 = tcLookupLocalValueOK "tcPat2" name `thenNF_Tc` \ id ->
68 tcPat pat `thenTc` \ (pat', lie, ty) ->
69 tcAddErrCtxt (patCtxt pat_in) $
70 unifyTauTy (idType id) ty `thenTc_`
71 returnTc (AsPat (TcId id) pat', lie, ty)
74 = newTyVarTy mkTypeKind `thenNF_Tc` \ tyvar_ty ->
75 returnTc (WildPat tyvar_ty, emptyLIE, tyvar_ty)
78 = tcPat (negate_lit pat)
80 negate_lit (LitPatIn (HsInt i)) = LitPatIn (HsInt (-i))
81 negate_lit (LitPatIn (HsFrac f)) = LitPatIn (HsFrac (-f))
82 negate_lit _ = panic "TcPat:negate_pat"
84 tcPat (ParPatIn parend_pat)
88 %************************************************************************
90 \subsection{Explicit lists and tuples}
92 %************************************************************************
95 tcPat pat_in@(ListPatIn pats)
96 = tcPats pats `thenTc` \ (pats', lie, tys) ->
97 newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ tyvar_ty ->
98 tcAddErrCtxt (patCtxt pat_in) $
99 unifyTauTyList (tyvar_ty:tys) `thenTc_`
101 returnTc (ListPat tyvar_ty pats', lie, mkListTy tyvar_ty)
103 tcPat pat_in@(TuplePatIn pats)
107 tcPats pats `thenTc` \ (pats', lie, tys) ->
109 -- Make sure we record that the tuples can only contain boxed types
110 newTyVarTys arity mkBoxedTypeKind `thenNF_Tc` \ tyvar_tys ->
112 tcAddErrCtxt (patCtxt pat_in) $
113 unifyTauTyLists tyvar_tys tys `thenTc_`
115 -- possibly do the "make all tuple-pats irrefutable" test:
117 unmangled_result = TuplePat pats'
119 -- Under flag control turn a pattern (x,y,z) into ~(x,y,z)
120 -- so that we can experiment with lazy tuple-matching.
121 -- This is a pretty odd place to make the switch, but
122 -- it was easy to do.
124 possibly_mangled_result
125 = if opt_IrrefutableTuples
126 then LazyPat unmangled_result
127 else unmangled_result
129 -- ToDo: IrrefutableEverything
131 returnTc (possibly_mangled_result, lie, mkTupleTy arity tys)
134 %************************************************************************
136 \subsection{Other constructors}
138 %************************************************************************
140 Constructor patterns are a little fun:
143 typecheck the arguments
145 look up the constructor
147 specialise its type (ignore the translation this produces)
149 check that the context produced by this specialisation is empty
151 get the arguments out of the function type produced from specialising
153 unify them with the types of the patterns
155 back substitute with the type of the result of the constructor
158 ToDo: exploit new representation of constructors to make this more
162 tcPat pat_in@(ConPatIn name pats)
163 = tcPats pats `thenTc` \ (pats', lie, tys) ->
165 tcAddErrCtxt (patCtxt pat_in) $
166 matchConArgTys name tys `thenTc` \ (con_id, data_ty) ->
168 returnTc (ConPat con_id data_ty pats',
172 tcPat pat_in@(ConOpPatIn pat1 op _ pat2) -- in binary-op form...
173 = tcPat pat1 `thenTc` \ (pat1', lie1, ty1) ->
174 tcPat pat2 `thenTc` \ (pat2', lie2, ty2) ->
176 tcAddErrCtxt (patCtxt pat_in) $
177 matchConArgTys op [ty1,ty2] `thenTc` \ (con_id, data_ty) ->
179 returnTc (ConOpPat pat1' con_id pat2' data_ty,
184 %************************************************************************
188 %************************************************************************
191 tcPat pat_in@(RecPatIn name rpats)
192 = tcLookupGlobalValue name `thenNF_Tc` \ con_id ->
193 tcInstId con_id `thenNF_Tc` \ (_, _, con_tau) ->
195 -- Ignore the con_theta; overloaded constructors only
196 -- behave differently when called, not when used for
198 (_, record_ty) = splitFunTys con_tau
200 -- Con is syntactically constrained to be a data constructor
201 ASSERT( maybeToBool (splitAlgTyConApp_maybe record_ty) )
203 mapAndUnzipTc (do_bind record_ty) rpats `thenTc` \ (rpats', lies) ->
205 returnTc (RecPat con_id record_ty rpats',
210 do_bind expected_record_ty (field_label, rhs_pat, pun_flag)
211 = tcLookupGlobalValue field_label `thenNF_Tc` \ sel_id ->
212 tcInstId sel_id `thenNF_Tc` \ (_, _, tau) ->
214 -- Record selectors all have type
215 -- forall a1..an. T a1 .. an -> tau
216 ASSERT( maybeToBool (splitFunTy_maybe tau) )
218 -- Selector must have type RecordType -> FieldType
219 Just (record_ty, field_ty) = splitFunTy_maybe tau
221 tcAddErrCtxt (recordLabel field_label) (
222 unifyTauTy expected_record_ty record_ty
224 tcPat rhs_pat `thenTc` \ (rhs_pat', lie, rhs_ty) ->
225 tcAddErrCtxt (recordRhs field_label rhs_pat) (
226 unifyTauTy field_ty rhs_ty
228 returnTc ((sel_id, rhs_pat', pun_flag), lie)
231 %************************************************************************
233 \subsection{Non-overloaded literals}
235 %************************************************************************
238 tcPat (LitPatIn lit@(HsChar str))
239 = returnTc (LitPat lit charTy, emptyLIE, charTy)
241 tcPat (LitPatIn lit@(HsString str))
242 = tcLookupGlobalValueByKey eqClassOpKey `thenNF_Tc` \ sel_id ->
243 newMethod (LiteralOrigin lit)
244 (RealId sel_id) [stringTy] `thenNF_Tc` \ (lie, eq_id) ->
246 comp_op = HsApp (HsVar eq_id) (HsLitOut lit stringTy)
248 returnTc (NPat lit stringTy comp_op, lie, stringTy)
250 tcPat (LitPatIn lit@(HsIntPrim _))
251 = returnTc (LitPat lit intPrimTy, emptyLIE, intPrimTy)
252 tcPat (LitPatIn lit@(HsCharPrim _))
253 = returnTc (LitPat lit charPrimTy, emptyLIE, charPrimTy)
254 tcPat (LitPatIn lit@(HsStringPrim _))
255 = returnTc (LitPat lit addrPrimTy, emptyLIE, addrPrimTy)
256 tcPat (LitPatIn lit@(HsFloatPrim _))
257 = returnTc (LitPat lit floatPrimTy, emptyLIE, floatPrimTy)
258 tcPat (LitPatIn lit@(HsDoublePrim _))
259 = returnTc (LitPat lit doublePrimTy, emptyLIE, doublePrimTy)
262 %************************************************************************
264 \subsection{Overloaded patterns: int literals and \tr{n+k} patterns}
266 %************************************************************************
269 tcPat (LitPatIn lit@(HsInt i))
270 = newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ tyvar_ty ->
271 newOverloadedLit origin
272 (OverloadedIntegral i) tyvar_ty `thenNF_Tc` \ (over_lit_expr, lie1) ->
274 tcLookupGlobalValueByKey eqClassOpKey `thenNF_Tc` \ eq_sel_id ->
275 newMethod origin (RealId eq_sel_id) [tyvar_ty] `thenNF_Tc` \ (lie2, eq_id) ->
277 returnTc (NPat lit tyvar_ty (HsApp (HsVar eq_id)
282 origin = LiteralOrigin lit
284 tcPat (LitPatIn lit@(HsFrac f))
285 = newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ tyvar_ty ->
286 newOverloadedLit origin
287 (OverloadedFractional f) tyvar_ty `thenNF_Tc` \ (over_lit_expr, lie1) ->
289 tcLookupGlobalValueByKey eqClassOpKey `thenNF_Tc` \ eq_sel_id ->
290 newMethod origin (RealId eq_sel_id) [tyvar_ty] `thenNF_Tc` \ (lie2, eq_id) ->
292 returnTc (NPat lit tyvar_ty (HsApp (HsVar eq_id)
297 origin = LiteralOrigin lit
299 tcPat (LitPatIn lit@(HsLitLit s))
300 = error "tcPat: can't handle ``literal-literal'' patterns"
302 tcPat (NPlusKPatIn name lit@(HsInt i))
303 = tcLookupLocalValueOK "tcPat1:n+k" name `thenNF_Tc` \ local ->
305 local_ty = idType local
307 tcLookupGlobalValueByKey geClassOpKey `thenNF_Tc` \ ge_sel_id ->
308 tcLookupGlobalValueByKey minusClassOpKey `thenNF_Tc` \ minus_sel_id ->
310 newOverloadedLit origin
311 (OverloadedIntegral i) local_ty `thenNF_Tc` \ (over_lit_expr, lie1) ->
313 newMethod origin (RealId ge_sel_id) [local_ty] `thenNF_Tc` \ (lie2, ge_id) ->
314 newMethod origin (RealId minus_sel_id) [local_ty] `thenNF_Tc` \ (lie3, minus_id) ->
316 returnTc (NPlusKPat (TcId local) lit local_ty
317 (SectionR (HsVar ge_id) over_lit_expr)
318 (SectionR (HsVar minus_id) over_lit_expr),
319 lie1 `plusLIE` lie2 `plusLIE` lie3,
322 origin = LiteralOrigin lit -- Not very good!
324 tcPat (NPlusKPatIn pat other) = panic "TcPat:NPlusKPat: not an HsInt literal"
327 %************************************************************************
329 \subsection{Lists of patterns}
331 %************************************************************************
334 tcPats :: [RenamedPat] -> TcM s ([TcPat s], LIE s, [TcType s])
336 tcPats [] = returnTc ([], emptyLIE, [])
339 = tcPat pat `thenTc` \ (pat', lie, ty) ->
340 tcPats pats `thenTc` \ (pats', lie', tys) ->
342 returnTc (pat':pats', plusLIE lie lie', ty:tys)
345 @matchConArgTys@ grabs the signature of the data constructor, and
346 unifies the actual args against the expected ones.
349 matchConArgTys :: Name -> [TcType s] -> TcM s (Id, TcType s)
351 matchConArgTys con arg_tys
352 = tcLookupGlobalValue con `thenNF_Tc` \ con_id ->
353 tcInstId con_id `thenNF_Tc` \ (_, _, con_tau) ->
354 -- Ignore the con_theta; overloaded constructors only
355 -- behave differently when called, not when used for
358 (con_args, con_result) = splitFunTys con_tau
359 con_arity = length con_args
360 no_of_args = length arg_tys
362 checkTc (con_arity == no_of_args)
363 (arityErr "Constructor" con_id con_arity no_of_args) `thenTc_`
365 unifyTauTyLists con_args arg_tys `thenTc_`
366 returnTc (con_id, con_result)
370 % =================================================
375 patCtxt pat = hang (ptext SLIT("In the pattern:"))
378 recordLabel field_label
379 = hang (hcat [ptext SLIT("When matching record field"), ppr field_label])
380 4 (hcat [ptext SLIT("with its immediately enclosing constructor")])
382 recordRhs field_label pat
383 = hang (ptext SLIT("In the record field pattern"))
384 4 (sep [ppr field_label, char '=', ppr pat])