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 Type ( splitFunTys, splitRhoTy,
33 splitFunTy_maybe, splitAlgTyConApp_maybe,
36 import TysPrim ( charPrimTy, intPrimTy, floatPrimTy,
37 doublePrimTy, addrPrimTy
39 import TysWiredIn ( charTy, stringTy, mkListTy, mkTupleTy, intTy )
40 import Unique ( Unique, eqClassOpKey, geClassOpKey, minusClassOpKey )
41 import Util ( assertPanic, panic )
46 tcPat :: RenamedPat -> TcM s (TcPat s, LIE s, TcType s)
49 %************************************************************************
51 \subsection{Variables, wildcards, lazy pats, as-pats}
53 %************************************************************************
57 = tcLookupLocalValueOK "tcPat1:" name `thenNF_Tc` \ id ->
58 returnTc (VarPat (TcId id), emptyLIE, idType id)
61 = tcPat pat `thenTc` \ (pat', lie, ty) ->
62 returnTc (LazyPat pat', lie, ty)
64 tcPat pat_in@(AsPatIn name pat)
65 = tcLookupLocalValueOK "tcPat2" name `thenNF_Tc` \ id ->
66 tcPat pat `thenTc` \ (pat', lie, ty) ->
67 tcAddErrCtxt (patCtxt pat_in) $
68 unifyTauTy (idType id) ty `thenTc_`
69 returnTc (AsPat (TcId id) pat', lie, ty)
72 = newTyVarTy mkTypeKind `thenNF_Tc` \ tyvar_ty ->
73 returnTc (WildPat tyvar_ty, emptyLIE, tyvar_ty)
76 = tcPat (negate_lit pat)
78 negate_lit (LitPatIn (HsInt i)) = LitPatIn (HsInt (-i))
79 negate_lit (LitPatIn (HsFrac f)) = LitPatIn (HsFrac (-f))
80 negate_lit _ = panic "TcPat:negate_pat"
82 tcPat (ParPatIn parend_pat)
86 %************************************************************************
88 \subsection{Explicit lists and tuples}
90 %************************************************************************
93 tcPat pat_in@(ListPatIn pats)
94 = tcPats pats `thenTc` \ (pats', lie, tys) ->
95 newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ tyvar_ty ->
96 tcAddErrCtxt (patCtxt pat_in) $
97 unifyTauTyList (tyvar_ty:tys) `thenTc_`
99 returnTc (ListPat tyvar_ty pats', lie, mkListTy tyvar_ty)
101 tcPat pat_in@(TuplePatIn pats)
105 tcPats pats `thenTc` \ (pats', lie, tys) ->
107 -- Make sure we record that the tuples can only contain boxed types
108 newTyVarTys arity mkBoxedTypeKind `thenNF_Tc` \ tyvar_tys ->
110 tcAddErrCtxt (patCtxt pat_in) $
111 unifyTauTyLists tyvar_tys tys `thenTc_`
113 -- possibly do the "make all tuple-pats irrefutable" test:
115 unmangled_result = TuplePat pats'
117 -- Under flag control turn a pattern (x,y,z) into ~(x,y,z)
118 -- so that we can experiment with lazy tuple-matching.
119 -- This is a pretty odd place to make the switch, but
120 -- it was easy to do.
122 possibly_mangled_result
123 = if opt_IrrefutableTuples
124 then LazyPat unmangled_result
125 else unmangled_result
127 -- ToDo: IrrefutableEverything
129 returnTc (possibly_mangled_result, lie, mkTupleTy arity tys)
132 %************************************************************************
134 \subsection{Other constructors}
136 %************************************************************************
138 Constructor patterns are a little fun:
141 typecheck the arguments
143 look up the constructor
145 specialise its type (ignore the translation this produces)
147 check that the context produced by this specialisation is empty
149 get the arguments out of the function type produced from specialising
151 unify them with the types of the patterns
153 back substitute with the type of the result of the constructor
156 ToDo: exploit new representation of constructors to make this more
160 tcPat pat_in@(ConPatIn name pats)
161 = tcPats pats `thenTc` \ (pats', lie, tys) ->
163 tcAddErrCtxt (patCtxt pat_in) $
164 matchConArgTys name tys `thenTc` \ (con_id, data_ty) ->
166 returnTc (ConPat con_id data_ty pats',
170 tcPat pat_in@(ConOpPatIn pat1 op _ pat2) -- in binary-op form...
171 = tcPat pat1 `thenTc` \ (pat1', lie1, ty1) ->
172 tcPat pat2 `thenTc` \ (pat2', lie2, ty2) ->
174 tcAddErrCtxt (patCtxt pat_in) $
175 matchConArgTys op [ty1,ty2] `thenTc` \ (con_id, data_ty) ->
177 returnTc (ConOpPat pat1' con_id pat2' data_ty,
182 %************************************************************************
186 %************************************************************************
189 tcPat pat_in@(RecPatIn name rpats)
190 = tcLookupGlobalValue name `thenNF_Tc` \ con_id ->
191 tcInstId con_id `thenNF_Tc` \ (_, _, con_tau) ->
193 -- Ignore the con_theta; overloaded constructors only
194 -- behave differently when called, not when used for
196 (_, record_ty) = splitFunTys con_tau
198 -- Con is syntactically constrained to be a data constructor
199 ASSERT( maybeToBool (splitAlgTyConApp_maybe record_ty) )
201 mapAndUnzipTc (do_bind record_ty) rpats `thenTc` \ (rpats', lies) ->
203 returnTc (RecPat con_id record_ty rpats',
208 do_bind expected_record_ty (field_label, rhs_pat, pun_flag)
209 = tcLookupGlobalValue field_label `thenNF_Tc` \ sel_id ->
210 tcInstId sel_id `thenNF_Tc` \ (_, _, tau) ->
212 -- Record selectors all have type
213 -- forall a1..an. T a1 .. an -> tau
214 ASSERT( maybeToBool (splitFunTy_maybe tau) )
216 -- Selector must have type RecordType -> FieldType
217 Just (record_ty, field_ty) = splitFunTy_maybe tau
219 tcAddErrCtxt (recordLabel field_label) (
220 unifyTauTy expected_record_ty record_ty
222 tcPat rhs_pat `thenTc` \ (rhs_pat', lie, rhs_ty) ->
223 tcAddErrCtxt (recordRhs field_label rhs_pat) (
224 unifyTauTy field_ty rhs_ty
226 returnTc ((sel_id, rhs_pat', pun_flag), lie)
229 %************************************************************************
231 \subsection{Non-overloaded literals}
233 %************************************************************************
236 tcPat (LitPatIn lit@(HsChar str))
237 = returnTc (LitPat lit charTy, emptyLIE, charTy)
239 tcPat (LitPatIn lit@(HsString str))
240 = tcLookupGlobalValueByKey eqClassOpKey `thenNF_Tc` \ sel_id ->
241 newMethod (LiteralOrigin lit)
242 (RealId sel_id) [stringTy] `thenNF_Tc` \ (lie, eq_id) ->
244 comp_op = HsApp (HsVar eq_id) (HsLitOut lit stringTy)
246 returnTc (NPat lit stringTy comp_op, lie, stringTy)
248 tcPat (LitPatIn lit@(HsIntPrim _))
249 = returnTc (LitPat lit intPrimTy, emptyLIE, intPrimTy)
250 tcPat (LitPatIn lit@(HsCharPrim _))
251 = returnTc (LitPat lit charPrimTy, emptyLIE, charPrimTy)
252 tcPat (LitPatIn lit@(HsStringPrim _))
253 = returnTc (LitPat lit addrPrimTy, emptyLIE, addrPrimTy)
254 tcPat (LitPatIn lit@(HsFloatPrim _))
255 = returnTc (LitPat lit floatPrimTy, emptyLIE, floatPrimTy)
256 tcPat (LitPatIn lit@(HsDoublePrim _))
257 = returnTc (LitPat lit doublePrimTy, emptyLIE, doublePrimTy)
260 %************************************************************************
262 \subsection{Overloaded patterns: int literals and \tr{n+k} patterns}
264 %************************************************************************
267 tcPat (LitPatIn lit@(HsInt i))
268 = newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ tyvar_ty ->
269 newOverloadedLit origin
270 (OverloadedIntegral i) tyvar_ty `thenNF_Tc` \ (over_lit_expr, lie1) ->
272 tcLookupGlobalValueByKey eqClassOpKey `thenNF_Tc` \ eq_sel_id ->
273 newMethod origin (RealId eq_sel_id) [tyvar_ty] `thenNF_Tc` \ (lie2, eq_id) ->
275 returnTc (NPat lit tyvar_ty (HsApp (HsVar eq_id)
280 origin = LiteralOrigin lit
282 tcPat (LitPatIn lit@(HsFrac f))
283 = newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ tyvar_ty ->
284 newOverloadedLit origin
285 (OverloadedFractional f) tyvar_ty `thenNF_Tc` \ (over_lit_expr, lie1) ->
287 tcLookupGlobalValueByKey eqClassOpKey `thenNF_Tc` \ eq_sel_id ->
288 newMethod origin (RealId eq_sel_id) [tyvar_ty] `thenNF_Tc` \ (lie2, eq_id) ->
290 returnTc (NPat lit tyvar_ty (HsApp (HsVar eq_id)
295 origin = LiteralOrigin lit
297 tcPat (LitPatIn lit@(HsLitLit s))
298 -- = error "tcPat: can't handle ``literal-literal'' patterns"
299 = returnTc (LitPat lit intTy, emptyLIE, intTy)
301 tcPat (NPlusKPatIn name lit@(HsInt i))
302 = tcLookupLocalValueOK "tcPat1:n+k" name `thenNF_Tc` \ local ->
304 local_ty = idType local
306 tcLookupGlobalValueByKey geClassOpKey `thenNF_Tc` \ ge_sel_id ->
307 tcLookupGlobalValueByKey minusClassOpKey `thenNF_Tc` \ minus_sel_id ->
309 newOverloadedLit origin
310 (OverloadedIntegral i) local_ty `thenNF_Tc` \ (over_lit_expr, lie1) ->
312 newMethod origin (RealId ge_sel_id) [local_ty] `thenNF_Tc` \ (lie2, ge_id) ->
313 newMethod origin (RealId minus_sel_id) [local_ty] `thenNF_Tc` \ (lie3, minus_id) ->
315 returnTc (NPlusKPat (TcId local) lit local_ty
316 (SectionR (HsVar ge_id) over_lit_expr)
317 (SectionR (HsVar minus_id) over_lit_expr),
318 lie1 `plusLIE` lie2 `plusLIE` lie3,
321 origin = LiteralOrigin lit -- Not very good!
323 tcPat (NPlusKPatIn pat other) = panic "TcPat:NPlusKPat: not an HsInt literal"
326 %************************************************************************
328 \subsection{Lists of patterns}
330 %************************************************************************
333 tcPats :: [RenamedPat] -> TcM s ([TcPat s], LIE s, [TcType s])
335 tcPats [] = returnTc ([], emptyLIE, [])
338 = tcPat pat `thenTc` \ (pat', lie, ty) ->
339 tcPats pats `thenTc` \ (pats', lie', tys) ->
341 returnTc (pat':pats', plusLIE lie lie', ty:tys)
344 @matchConArgTys@ grabs the signature of the data constructor, and
345 unifies the actual args against the expected ones.
348 matchConArgTys :: Name -> [TcType s] -> TcM s (Id, TcType s)
350 matchConArgTys con arg_tys
351 = tcLookupGlobalValue con `thenNF_Tc` \ con_id ->
352 tcInstId con_id `thenNF_Tc` \ (_, _, con_tau) ->
353 -- Ignore the con_theta; overloaded constructors only
354 -- behave differently when called, not when used for
357 (con_args, con_result) = splitFunTys con_tau
358 con_arity = length con_args
359 no_of_args = length arg_tys
361 checkTc (con_arity == no_of_args)
362 (arityErr "Constructor" con_id con_arity no_of_args) `thenTc_`
364 unifyTauTyLists con_args arg_tys `thenTc_`
365 returnTc (con_id, con_result)
369 % =================================================
374 patCtxt pat = hang (ptext SLIT("In the pattern:"))
377 recordLabel field_label
378 = hang (hcat [ptext SLIT("When matching record field"), ppr field_label])
379 4 (hcat [ptext SLIT("with its immediately enclosing constructor")])
381 recordRhs field_label pat
382 = hang (ptext SLIT("In the record field pattern"))
383 4 (sep [ppr field_label, char '=', ppr pat])