2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[TcPat]{Typechecking patterns}
7 #include "HsVersions.h"
9 module TcPat ( tcPat ) where
13 import HsSyn ( InPat(..), OutPat(..), HsExpr(..), HsLit(..),
14 Match, HsBinds, HsType, Fixity,
15 ArithSeqInfo, Stmt, DoOrListComp, Fake )
16 import RnHsSyn ( SYN_IE(RenamedPat) )
17 import TcHsSyn ( SYN_IE(TcPat) )
20 import Inst ( Inst, OverloadedLit(..), InstOrigin(..),
21 emptyLIE, plusLIE, plusLIEs, SYN_IE(LIE),
22 newMethod, newOverloadedLit
24 import Name ( Name {- instance Outputable -} )
25 import TcEnv ( tcLookupGlobalValue, tcLookupGlobalValueByKey,
26 tcLookupLocalValueOK )
27 import SpecEnv ( SpecEnv )
28 import TcType ( TcIdOcc(..), SYN_IE(TcType), TcMaybe, newTyVarTy, newTyVarTys, tcInstId )
29 import Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists )
32 import CmdLineOpts ( opt_IrrefutableTuples )
33 import Id ( GenId, idType, SYN_IE(Id) )
34 import Kind ( Kind, mkBoxedTypeKind, mkTypeKind )
35 import Maybes ( maybeToBool )
36 import PprType ( GenType, GenTyVar )
38 import Type ( splitFunTy, splitRhoTy, splitSigmaTy, mkTyVarTys,
39 getFunTy_maybe, maybeAppDataTyCon,
42 import TyVar ( GenTyVar )
43 import TysPrim ( charPrimTy, intPrimTy, floatPrimTy,
44 doublePrimTy, addrPrimTy
46 import TysWiredIn ( charTy, stringTy, mkListTy, mkTupleTy, addrTy )
47 import Unique ( Unique, eqClassOpKey, geClassOpKey, minusClassOpKey )
48 import Util ( assertPanic, panic )
50 #if __GLASGOW_HASKELL__ >= 202
56 tcPat :: RenamedPat -> TcM s (TcPat s, LIE s, TcType s)
59 %************************************************************************
61 \subsection{Variables, wildcards, lazy pats, as-pats}
63 %************************************************************************
67 = tcLookupLocalValueOK "tcPat1:" name `thenNF_Tc` \ id ->
68 returnTc (VarPat (TcId id), emptyLIE, idType id)
71 = tcPat pat `thenTc` \ (pat', lie, ty) ->
72 returnTc (LazyPat pat', lie, ty)
74 tcPat pat_in@(AsPatIn name pat)
75 = tcLookupLocalValueOK "tcPat2" name `thenNF_Tc` \ id ->
76 tcPat pat `thenTc` \ (pat', lie, ty) ->
77 tcAddErrCtxt (patCtxt pat_in) $
78 unifyTauTy (idType id) ty `thenTc_`
79 returnTc (AsPat (TcId id) pat', lie, ty)
82 = newTyVarTy mkTypeKind `thenNF_Tc` \ tyvar_ty ->
83 returnTc (WildPat tyvar_ty, emptyLIE, tyvar_ty)
86 = tcPat (negate_lit pat)
88 negate_lit (LitPatIn (HsInt i)) = LitPatIn (HsInt (-i))
89 negate_lit (LitPatIn (HsFrac f)) = LitPatIn (HsFrac (-f))
90 negate_lit _ = panic "TcPat:negate_pat"
92 tcPat (ParPatIn parend_pat)
96 %************************************************************************
98 \subsection{Explicit lists and tuples}
100 %************************************************************************
103 tcPat pat_in@(ListPatIn pats)
104 = tcPats pats `thenTc` \ (pats', lie, tys) ->
105 newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ tyvar_ty ->
106 tcAddErrCtxt (patCtxt pat_in) $
107 unifyTauTyList (tyvar_ty:tys) `thenTc_`
109 returnTc (ListPat tyvar_ty pats', lie, mkListTy tyvar_ty)
111 tcPat pat_in@(TuplePatIn pats)
115 tcPats pats `thenTc` \ (pats', lie, tys) ->
117 -- Make sure we record that the tuples can only contain boxed types
118 newTyVarTys arity mkBoxedTypeKind `thenNF_Tc` \ tyvar_tys ->
120 tcAddErrCtxt (patCtxt pat_in) $
121 unifyTauTyLists tyvar_tys tys `thenTc_`
123 -- possibly do the "make all tuple-pats irrefutable" test:
125 unmangled_result = TuplePat pats'
127 -- Under flag control turn a pattern (x,y,z) into ~(x,y,z)
128 -- so that we can experiment with lazy tuple-matching.
129 -- This is a pretty odd place to make the switch, but
130 -- it was easy to do.
132 possibly_mangled_result
133 = if opt_IrrefutableTuples
134 then LazyPat unmangled_result
135 else unmangled_result
137 -- ToDo: IrrefutableEverything
139 returnTc (possibly_mangled_result, lie, mkTupleTy arity tys)
142 %************************************************************************
144 \subsection{Other constructors}
146 %************************************************************************
148 Constructor patterns are a little fun:
151 typecheck the arguments
153 look up the constructor
155 specialise its type (ignore the translation this produces)
157 check that the context produced by this specialisation is empty
159 get the arguments out of the function type produced from specialising
161 unify them with the types of the patterns
163 back substitute with the type of the result of the constructor
166 ToDo: exploit new representation of constructors to make this more
170 tcPat pat_in@(ConPatIn name pats)
171 = tcPats pats `thenTc` \ (pats', lie, tys) ->
173 tcAddErrCtxt (patCtxt pat_in) $
174 matchConArgTys name tys `thenTc` \ (con_id, data_ty) ->
176 returnTc (ConPat con_id data_ty pats',
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) ->
184 tcAddErrCtxt (patCtxt pat_in) $
185 matchConArgTys op [ty1,ty2] `thenTc` \ (con_id, data_ty) ->
187 returnTc (ConOpPat pat1' con_id pat2' data_ty,
192 %************************************************************************
196 %************************************************************************
199 tcPat pat_in@(RecPatIn name rpats)
200 = tcLookupGlobalValue name `thenNF_Tc` \ con_id ->
201 tcInstId con_id `thenNF_Tc` \ (_, _, con_tau) ->
203 -- Ignore the con_theta; overloaded constructors only
204 -- behave differently when called, not when used for
206 (_, record_ty) = splitFunTy con_tau
208 -- Con is syntactically constrained to be a data constructor
209 ASSERT( maybeToBool (maybeAppDataTyCon record_ty) )
211 mapAndUnzipTc (do_bind record_ty) rpats `thenTc` \ (rpats', lies) ->
213 returnTc (RecPat con_id record_ty rpats',
218 do_bind expected_record_ty (field_label, rhs_pat, pun_flag)
219 = tcLookupGlobalValue field_label `thenNF_Tc` \ sel_id ->
220 tcInstId sel_id `thenNF_Tc` \ (_, _, tau) ->
222 -- Record selectors all have type
223 -- forall a1..an. T a1 .. an -> tau
224 ASSERT( maybeToBool (getFunTy_maybe tau) )
226 -- Selector must have type RecordType -> FieldType
227 Just (record_ty, field_ty) = getFunTy_maybe tau
229 tcAddErrCtxt (recordLabel field_label) (
230 unifyTauTy expected_record_ty record_ty
232 tcPat rhs_pat `thenTc` \ (rhs_pat', lie, rhs_ty) ->
233 tcAddErrCtxt (recordRhs field_label rhs_pat) (
234 unifyTauTy field_ty rhs_ty
236 returnTc ((sel_id, rhs_pat', pun_flag), lie)
239 %************************************************************************
241 \subsection{Non-overloaded literals}
243 %************************************************************************
246 tcPat (LitPatIn lit@(HsChar str))
247 = returnTc (LitPat lit charTy, emptyLIE, charTy)
249 tcPat (LitPatIn lit@(HsString str))
250 = tcLookupGlobalValueByKey eqClassOpKey `thenNF_Tc` \ sel_id ->
251 newMethod (LiteralOrigin lit)
252 (RealId sel_id) [stringTy] `thenNF_Tc` \ (lie, eq_id) ->
254 comp_op = HsApp (HsVar eq_id) (HsLitOut lit stringTy)
256 returnTc (NPat lit stringTy comp_op, lie, stringTy)
258 tcPat (LitPatIn lit@(HsIntPrim _))
259 = returnTc (LitPat lit intPrimTy, emptyLIE, intPrimTy)
260 tcPat (LitPatIn lit@(HsCharPrim _))
261 = returnTc (LitPat lit charPrimTy, emptyLIE, charPrimTy)
262 tcPat (LitPatIn lit@(HsStringPrim _))
263 = returnTc (LitPat lit addrPrimTy, emptyLIE, addrPrimTy)
264 tcPat (LitPatIn lit@(HsFloatPrim _))
265 = returnTc (LitPat lit floatPrimTy, emptyLIE, floatPrimTy)
266 tcPat (LitPatIn lit@(HsDoublePrim _))
267 = returnTc (LitPat lit doublePrimTy, emptyLIE, doublePrimTy)
270 %************************************************************************
272 \subsection{Overloaded patterns: int literals and \tr{n+k} patterns}
274 %************************************************************************
277 tcPat (LitPatIn lit@(HsInt i))
278 = newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ tyvar_ty ->
279 newOverloadedLit origin
280 (OverloadedIntegral i) tyvar_ty `thenNF_Tc` \ (over_lit_expr, lie1) ->
282 tcLookupGlobalValueByKey eqClassOpKey `thenNF_Tc` \ eq_sel_id ->
283 newMethod origin (RealId eq_sel_id) [tyvar_ty] `thenNF_Tc` \ (lie2, eq_id) ->
285 returnTc (NPat lit tyvar_ty (HsApp (HsVar eq_id)
290 origin = LiteralOrigin lit
292 tcPat (LitPatIn lit@(HsFrac f))
293 = newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ tyvar_ty ->
294 newOverloadedLit origin
295 (OverloadedFractional f) tyvar_ty `thenNF_Tc` \ (over_lit_expr, lie1) ->
297 tcLookupGlobalValueByKey eqClassOpKey `thenNF_Tc` \ eq_sel_id ->
298 newMethod origin (RealId eq_sel_id) [tyvar_ty] `thenNF_Tc` \ (lie2, eq_id) ->
300 returnTc (NPat lit tyvar_ty (HsApp (HsVar eq_id)
305 origin = LiteralOrigin lit
307 tcPat (LitPatIn lit@(HsLitLit s))
308 = error "tcPat: can't handle ``literal-literal'' patterns"
310 tcPat (NPlusKPatIn name lit@(HsInt i))
311 = tcLookupLocalValueOK "tcPat1:n+k" name `thenNF_Tc` \ local ->
313 local_ty = idType local
315 tcLookupGlobalValueByKey geClassOpKey `thenNF_Tc` \ ge_sel_id ->
316 tcLookupGlobalValueByKey minusClassOpKey `thenNF_Tc` \ minus_sel_id ->
318 newOverloadedLit origin
319 (OverloadedIntegral i) local_ty `thenNF_Tc` \ (over_lit_expr, lie1) ->
321 newMethod origin (RealId ge_sel_id) [local_ty] `thenNF_Tc` \ (lie2, ge_id) ->
322 newMethod origin (RealId minus_sel_id) [local_ty] `thenNF_Tc` \ (lie3, minus_id) ->
324 returnTc (NPlusKPat (TcId local) lit local_ty
325 (SectionR (HsVar ge_id) over_lit_expr)
326 (SectionR (HsVar minus_id) over_lit_expr),
327 lie1 `plusLIE` lie2 `plusLIE` lie3,
330 origin = LiteralOrigin lit -- Not very good!
332 tcPat (NPlusKPatIn pat other) = panic "TcPat:NPlusKPat: not an HsInt literal"
335 %************************************************************************
337 \subsection{Lists of patterns}
339 %************************************************************************
342 tcPats :: [RenamedPat] -> TcM s ([TcPat s], LIE s, [TcType s])
344 tcPats [] = returnTc ([], emptyLIE, [])
347 = tcPat pat `thenTc` \ (pat', lie, ty) ->
348 tcPats pats `thenTc` \ (pats', lie', tys) ->
350 returnTc (pat':pats', plusLIE lie lie', ty:tys)
353 @matchConArgTys@ grabs the signature of the data constructor, and
354 unifies the actual args against the expected ones.
357 matchConArgTys :: Name -> [TcType s] -> TcM s (Id, TcType s)
359 matchConArgTys con arg_tys
360 = tcLookupGlobalValue con `thenNF_Tc` \ con_id ->
361 tcInstId con_id `thenNF_Tc` \ (_, _, con_tau) ->
362 -- Ignore the con_theta; overloaded constructors only
363 -- behave differently when called, not when used for
366 (con_args, con_result) = splitFunTy con_tau
367 con_arity = length con_args
368 no_of_args = length arg_tys
370 checkTc (con_arity == no_of_args)
371 (arityErr "Constructor" con_id con_arity no_of_args) `thenTc_`
373 unifyTauTyLists con_args arg_tys `thenTc_`
374 returnTc (con_id, con_result)
378 % =================================================
383 patCtxt pat sty = hang (ptext SLIT("In the pattern:")) 4 (ppr sty pat)
385 recordLabel field_label sty
386 = hang (hcat [ptext SLIT("When matching record field"), ppr sty field_label])
387 4 (hcat [ptext SLIT("with its immediately enclosing constructor")])
389 recordRhs field_label pat sty
390 = hang (ptext SLIT("In the record field pattern"))
391 4 (sep [ppr sty field_label, char '=', ppr sty pat])