2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[TcPat]{Typechecking patterns}
7 module TcPat ( tcPat, badFieldsCon ) 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 FieldLabel ( fieldLabelName )
26 import Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists )
28 import Maybes ( maybeToBool )
30 import CmdLineOpts ( opt_IrrefutableTuples )
31 import Id ( GenId, idType, Id, dataConFieldLabels )
32 import Kind ( Kind, mkBoxedTypeKind, mkTypeKind )
33 import Type ( splitFunTys, splitRhoTy,
34 splitFunTy_maybe, splitAlgTyConApp_maybe,
37 import TysPrim ( charPrimTy, intPrimTy, floatPrimTy,
38 doublePrimTy, addrPrimTy
40 import TysWiredIn ( charTy, stringTy, mkListTy, mkTupleTy, intTy )
41 import Unique ( Unique, eqClassOpKey, geClassOpKey, minusClassOpKey )
42 import Util ( assertPanic, panic )
47 tcPat :: RenamedPat -> TcM s (TcPat s, LIE s, TcType s)
50 %************************************************************************
52 \subsection{Variables, wildcards, lazy pats, as-pats}
54 %************************************************************************
58 = tcLookupLocalValueOK "tcPat1:" name `thenNF_Tc` \ id ->
59 returnTc (VarPat (TcId id), emptyLIE, idType id)
62 = tcPat pat `thenTc` \ (pat', lie, ty) ->
63 returnTc (LazyPat pat', lie, ty)
65 tcPat pat_in@(AsPatIn name pat)
66 = tcLookupLocalValueOK "tcPat2" name `thenNF_Tc` \ id ->
67 tcPat pat `thenTc` \ (pat', lie, ty) ->
68 tcAddErrCtxt (patCtxt pat_in) $
69 unifyTauTy (idType id) ty `thenTc_`
70 returnTc (AsPat (TcId id) pat', lie, ty)
73 = newTyVarTy mkTypeKind `thenNF_Tc` \ tyvar_ty ->
74 returnTc (WildPat tyvar_ty, emptyLIE, tyvar_ty)
77 = tcPat (negate_lit pat)
79 negate_lit (LitPatIn (HsInt i)) = LitPatIn (HsInt (-i))
80 negate_lit (LitPatIn (HsFrac f)) = LitPatIn (HsFrac (-f))
81 negate_lit _ = panic "TcPat:negate_pat"
83 tcPat (ParPatIn parend_pat)
87 %************************************************************************
89 \subsection{Explicit lists and tuples}
91 %************************************************************************
94 tcPat pat_in@(ListPatIn pats)
95 = tcPats pats `thenTc` \ (pats', lie, tys) ->
96 newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ tyvar_ty ->
97 tcAddErrCtxt (patCtxt pat_in) $
98 unifyTauTyList (tyvar_ty:tys) `thenTc_`
100 returnTc (ListPat tyvar_ty pats', lie, mkListTy tyvar_ty)
102 tcPat pat_in@(TuplePatIn pats)
106 tcPats pats `thenTc` \ (pats', lie, tys) ->
108 -- Make sure we record that the tuples can only contain boxed types
109 newTyVarTys arity mkBoxedTypeKind `thenNF_Tc` \ tyvar_tys ->
111 tcAddErrCtxt (patCtxt pat_in) $
112 unifyTauTyLists tyvar_tys tys `thenTc_`
114 -- possibly do the "make all tuple-pats irrefutable" test:
116 unmangled_result = TuplePat pats'
118 -- Under flag control turn a pattern (x,y,z) into ~(x,y,z)
119 -- so that we can experiment with lazy tuple-matching.
120 -- This is a pretty odd place to make the switch, but
121 -- it was easy to do.
123 possibly_mangled_result
124 = if opt_IrrefutableTuples
125 then LazyPat unmangled_result
126 else unmangled_result
128 -- ToDo: IrrefutableEverything
130 returnTc (possibly_mangled_result, lie, mkTupleTy arity tys)
133 %************************************************************************
135 \subsection{Other constructors}
137 %************************************************************************
139 Constructor patterns are a little fun:
142 typecheck the arguments
144 look up the constructor
146 specialise its type (ignore the translation this produces)
148 check that the context produced by this specialisation is empty
150 get the arguments out of the function type produced from specialising
152 unify them with the types of the patterns
154 back substitute with the type of the result of the constructor
157 ToDo: exploit new representation of constructors to make this more
161 tcPat pat_in@(ConPatIn name pats)
162 = tcPats pats `thenTc` \ (pats', lie, tys) ->
164 tcAddErrCtxt (patCtxt pat_in) $
165 matchConArgTys name tys `thenTc` \ (con_id, data_ty) ->
167 returnTc (ConPat con_id data_ty pats',
171 tcPat pat_in@(ConOpPatIn pat1 op _ pat2) -- in binary-op form...
172 = tcPat pat1 `thenTc` \ (pat1', lie1, ty1) ->
173 tcPat pat2 `thenTc` \ (pat2', lie2, ty2) ->
175 tcAddErrCtxt (patCtxt pat_in) $
176 matchConArgTys op [ty1,ty2] `thenTc` \ (con_id, data_ty) ->
178 returnTc (ConOpPat pat1' con_id pat2' data_ty,
183 %************************************************************************
187 %************************************************************************
190 tcPat pat_in@(RecPatIn name rpats)
191 = tcLookupGlobalValue name `thenNF_Tc` \ con_id ->
192 tcInstId con_id `thenNF_Tc` \ (_, _, con_tau) ->
194 -- Ignore the con_theta; overloaded constructors only
195 -- behave differently when called, not when used for
197 (_, record_ty) = splitFunTys con_tau
199 field_names = map fieldLabelName (dataConFieldLabels con_id)
200 bad_fields = [f | (f,_,_) <- rpats, not (f `elem` field_names)]
202 -- Check that all the fields are from this constructor
203 checkTc (null bad_fields) (badFieldsCon name bad_fields) `thenTc_`
205 -- Con is syntactically constrained to be a data constructor
206 ASSERT( maybeToBool (splitAlgTyConApp_maybe record_ty) )
208 mapAndUnzipTc (do_bind record_ty) rpats `thenTc` \ (rpats', lies) ->
210 returnTc (RecPat con_id record_ty rpats',
215 do_bind expected_record_ty (field_label, rhs_pat, pun_flag)
216 = tcLookupGlobalValue field_label `thenNF_Tc` \ sel_id ->
217 tcInstId sel_id `thenNF_Tc` \ (_, _, tau) ->
219 -- Record selectors all have type
220 -- forall a1..an. T a1 .. an -> tau
221 ASSERT( maybeToBool (splitFunTy_maybe tau) )
223 -- Selector must have type RecordType -> FieldType
224 Just (record_ty, field_ty) = splitFunTy_maybe tau
226 tcAddErrCtxt (recordLabel field_label) (
227 unifyTauTy expected_record_ty record_ty
229 tcPat rhs_pat `thenTc` \ (rhs_pat', lie, rhs_ty) ->
230 tcAddErrCtxt (recordRhs field_label rhs_pat) (
231 unifyTauTy field_ty rhs_ty
233 returnTc ((sel_id, rhs_pat', pun_flag), lie)
236 %************************************************************************
238 \subsection{Non-overloaded literals}
240 %************************************************************************
243 tcPat (LitPatIn lit@(HsChar str))
244 = returnTc (LitPat lit charTy, emptyLIE, charTy)
246 tcPat (LitPatIn lit@(HsString str))
247 = tcLookupGlobalValueByKey eqClassOpKey `thenNF_Tc` \ sel_id ->
248 newMethod (LiteralOrigin lit)
249 (RealId sel_id) [stringTy] `thenNF_Tc` \ (lie, eq_id) ->
251 comp_op = HsApp (HsVar eq_id) (HsLitOut lit stringTy)
253 returnTc (NPat lit stringTy comp_op, lie, stringTy)
255 tcPat (LitPatIn lit@(HsIntPrim _))
256 = returnTc (LitPat lit intPrimTy, emptyLIE, intPrimTy)
257 tcPat (LitPatIn lit@(HsCharPrim _))
258 = returnTc (LitPat lit charPrimTy, emptyLIE, charPrimTy)
259 tcPat (LitPatIn lit@(HsStringPrim _))
260 = returnTc (LitPat lit addrPrimTy, emptyLIE, addrPrimTy)
261 tcPat (LitPatIn lit@(HsFloatPrim _))
262 = returnTc (LitPat lit floatPrimTy, emptyLIE, floatPrimTy)
263 tcPat (LitPatIn lit@(HsDoublePrim _))
264 = returnTc (LitPat lit doublePrimTy, emptyLIE, doublePrimTy)
267 %************************************************************************
269 \subsection{Overloaded patterns: int literals and \tr{n+k} patterns}
271 %************************************************************************
274 tcPat (LitPatIn lit@(HsInt i))
275 = newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ tyvar_ty ->
276 newOverloadedLit origin
277 (OverloadedIntegral i) tyvar_ty `thenNF_Tc` \ (over_lit_expr, lie1) ->
279 tcLookupGlobalValueByKey eqClassOpKey `thenNF_Tc` \ eq_sel_id ->
280 newMethod origin (RealId eq_sel_id) [tyvar_ty] `thenNF_Tc` \ (lie2, eq_id) ->
282 returnTc (NPat lit tyvar_ty (HsApp (HsVar eq_id)
287 origin = LiteralOrigin lit
289 tcPat (LitPatIn lit@(HsFrac f))
290 = newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ tyvar_ty ->
291 newOverloadedLit origin
292 (OverloadedFractional f) tyvar_ty `thenNF_Tc` \ (over_lit_expr, lie1) ->
294 tcLookupGlobalValueByKey eqClassOpKey `thenNF_Tc` \ eq_sel_id ->
295 newMethod origin (RealId eq_sel_id) [tyvar_ty] `thenNF_Tc` \ (lie2, eq_id) ->
297 returnTc (NPat lit tyvar_ty (HsApp (HsVar eq_id)
302 origin = LiteralOrigin lit
304 tcPat (LitPatIn lit@(HsLitLit s))
305 -- = error "tcPat: can't handle ``literal-literal'' patterns"
306 = returnTc (LitPat lit intTy, emptyLIE, intTy)
308 tcPat (NPlusKPatIn name lit@(HsInt i))
309 = tcLookupLocalValueOK "tcPat1:n+k" name `thenNF_Tc` \ local ->
311 local_ty = idType local
313 tcLookupGlobalValueByKey geClassOpKey `thenNF_Tc` \ ge_sel_id ->
314 tcLookupGlobalValueByKey minusClassOpKey `thenNF_Tc` \ minus_sel_id ->
316 newOverloadedLit origin
317 (OverloadedIntegral i) local_ty `thenNF_Tc` \ (over_lit_expr, lie1) ->
319 newMethod origin (RealId ge_sel_id) [local_ty] `thenNF_Tc` \ (lie2, ge_id) ->
320 newMethod origin (RealId minus_sel_id) [local_ty] `thenNF_Tc` \ (lie3, minus_id) ->
322 returnTc (NPlusKPat (TcId local) lit local_ty
323 (SectionR (HsVar ge_id) over_lit_expr)
324 (SectionR (HsVar minus_id) over_lit_expr),
325 lie1 `plusLIE` lie2 `plusLIE` lie3,
328 origin = LiteralOrigin lit -- Not very good!
330 tcPat (NPlusKPatIn pat other) = panic "TcPat:NPlusKPat: not an HsInt literal"
333 %************************************************************************
335 \subsection{Lists of patterns}
337 %************************************************************************
340 tcPats :: [RenamedPat] -> TcM s ([TcPat s], LIE s, [TcType s])
342 tcPats [] = returnTc ([], emptyLIE, [])
345 = tcPat pat `thenTc` \ (pat', lie, ty) ->
346 tcPats pats `thenTc` \ (pats', lie', tys) ->
348 returnTc (pat':pats', plusLIE lie lie', ty:tys)
351 @matchConArgTys@ grabs the signature of the data constructor, and
352 unifies the actual args against the expected ones.
355 matchConArgTys :: Name -> [TcType s] -> TcM s (Id, TcType s)
357 matchConArgTys con arg_tys
358 = tcLookupGlobalValue con `thenNF_Tc` \ con_id ->
359 tcInstId con_id `thenNF_Tc` \ (_, _, con_tau) ->
360 -- Ignore the con_theta; overloaded constructors only
361 -- behave differently when called, not when used for
364 (con_args, con_result) = splitFunTys con_tau
365 con_arity = length con_args
366 no_of_args = length arg_tys
368 checkTc (con_arity == no_of_args)
369 (arityErr "Constructor" con_id con_arity no_of_args) `thenTc_`
371 unifyTauTyLists con_args arg_tys `thenTc_`
372 returnTc (con_id, con_result)
375 % =================================================
380 patCtxt pat = hang (ptext SLIT("In the pattern:"))
383 recordLabel field_label
384 = hang (hcat [ptext SLIT("When matching record field"), ppr field_label])
385 4 (hcat [ptext SLIT("with its immediately enclosing constructor")])
387 recordRhs field_label pat
388 = hang (ptext SLIT("In the record field pattern"))
389 4 (sep [ppr field_label, char '=', ppr pat])
391 badFieldsCon :: Name -> [Name] -> SDoc
392 badFieldsCon con fields
393 = hsep [ptext SLIT("Constructor") <+> quotes (ppr con),
394 ptext SLIT("does not have field(s):"), pprQuotedList fields]