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, Qual, PolyType,
15 ArithSeqInfo, Stmt, Fake )
16 import RnHsSyn ( RenamedPat(..) )
17 import TcHsSyn ( TcPat(..), TcIdOcc(..) )
19 import TcMonad hiding ( rnMtoTcM )
20 import Inst ( Inst, OverloadedLit(..), InstOrigin(..),
21 emptyLIE, plusLIE, plusLIEs, LIE(..),
22 newMethod, newOverloadedLit
24 import TcEnv ( tcLookupGlobalValue, tcLookupGlobalValueByKey,
25 tcLookupLocalValueOK )
26 import TcType ( TcType(..), TcMaybe, tcInstType, newTyVarTy, newTyVarTys, tcInstId )
27 import Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists )
30 import CmdLineOpts ( opt_IrrefutableTuples )
31 import Id ( GenId, idType )
32 import Kind ( Kind, mkBoxedTypeKind, mkTypeKind )
33 import Maybes ( maybeToBool )
34 import PprType ( GenType, GenTyVar )
35 import PrelInfo ( charPrimTy, intPrimTy, floatPrimTy,
36 doublePrimTy, charTy, stringTy, mkListTy,
37 mkTupleTy, addrTy, addrPrimTy )
39 import RnHsSyn ( RnName{-instance Outputable-} )
40 import Type ( splitFunTy, splitRhoTy, splitSigmaTy, mkTyVarTys,
41 getFunTy_maybe, maybeAppDataTyCon,
44 import TyVar ( GenTyVar )
45 import Unique ( Unique, eqClassOpKey )
46 import Util ( assertPanic, panic{-ToDo:rm-} )
50 tcPat :: RenamedPat -> TcM s (TcPat s, LIE s, TcType s)
53 %************************************************************************
55 \subsection{Variables, wildcards, lazy pats, as-pats}
57 %************************************************************************
61 = tcLookupLocalValueOK "tcPat1" name `thenNF_Tc` \ id ->
62 returnTc (VarPat (TcId id), emptyLIE, idType id)
65 = tcPat pat `thenTc` \ (pat', lie, ty) ->
66 returnTc (LazyPat pat', lie, ty)
68 tcPat pat_in@(AsPatIn name pat)
69 = tcLookupLocalValueOK "tcPat2" name `thenNF_Tc` \ id ->
70 tcPat pat `thenTc` \ (pat', lie, ty) ->
71 tcAddErrCtxt (patCtxt pat_in) $
72 unifyTauTy (idType id) ty `thenTc_`
73 returnTc (AsPat (TcId id) pat', lie, ty)
76 = newTyVarTy mkTypeKind `thenNF_Tc` \ tyvar_ty ->
77 returnTc (WildPat tyvar_ty, emptyLIE, tyvar_ty)
80 = tcPat (negate_lit pat)
82 negate_lit (LitPatIn (HsInt i)) = LitPatIn (HsInt (-i))
83 negate_lit (LitPatIn (HsFrac f)) = LitPatIn (HsFrac (-f))
84 negate_lit _ = panic "TcPat:negate_pat"
86 tcPat (ParPatIn parend_pat)
90 %************************************************************************
92 \subsection{Explicit lists and tuples}
94 %************************************************************************
97 tcPat pat_in@(ListPatIn pats)
98 = tcPats pats `thenTc` \ (pats', lie, tys) ->
99 newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ tyvar_ty ->
100 tcAddErrCtxt (patCtxt pat_in) $
101 unifyTauTyList (tyvar_ty:tys) `thenTc_`
103 returnTc (ListPat tyvar_ty pats', lie, mkListTy tyvar_ty)
105 tcPat pat_in@(TuplePatIn pats)
109 tcPats pats `thenTc` \ (pats', lie, tys) ->
111 -- Make sure we record that the tuples can only contain boxed types
112 newTyVarTys arity mkBoxedTypeKind `thenNF_Tc` \ tyvar_tys ->
114 tcAddErrCtxt (patCtxt pat_in) $
115 unifyTauTyLists tyvar_tys tys `thenTc_`
117 -- possibly do the "make all tuple-pats irrefutable" test:
119 unmangled_result = TuplePat pats'
121 -- Under flag control turn a pattern (x,y,z) into ~(x,y,z)
122 -- so that we can experiment with lazy tuple-matching.
123 -- This is a pretty odd place to make the switch, but
124 -- it was easy to do.
126 possibly_mangled_result
127 = if opt_IrrefutableTuples
128 then LazyPat unmangled_result
129 else unmangled_result
131 -- ToDo: IrrefutableEverything
133 returnTc (possibly_mangled_result, lie, mkTupleTy arity tys)
136 %************************************************************************
138 \subsection{Other constructors}
140 %************************************************************************
142 Constructor patterns are a little fun:
145 typecheck the arguments
147 look up the constructor
149 specialise its type (ignore the translation this produces)
151 check that the context produced by this specialisation is empty
153 get the arguments out of the function type produced from specialising
155 unify them with the types of the patterns
157 back substitute with the type of the result of the constructor
160 ToDo: exploit new representation of constructors to make this more
164 tcPat pat_in@(ConPatIn name pats)
165 = tcPats pats `thenTc` \ (pats', lie, tys) ->
167 tcAddErrCtxt (patCtxt pat_in) $
168 matchConArgTys name tys `thenTc` \ (con_id, data_ty) ->
170 returnTc (ConPat con_id data_ty pats',
174 tcPat pat_in@(ConOpPatIn pat1 op pat2) -- in binary-op form...
175 = tcPat pat1 `thenTc` \ (pat1', lie1, ty1) ->
176 tcPat pat2 `thenTc` \ (pat2', lie2, ty2) ->
178 tcAddErrCtxt (patCtxt pat_in) $
179 matchConArgTys op [ty1,ty2] `thenTc` \ (con_id, data_ty) ->
181 returnTc (ConOpPat pat1' con_id pat2' data_ty,
186 %************************************************************************
190 %************************************************************************
193 tcPat pat_in@(RecPatIn name rpats)
194 = tcLookupGlobalValue name `thenNF_Tc` \ con_id ->
195 tcInstId con_id `thenNF_Tc` \ (_, _, con_tau) ->
197 -- Ignore the con_theta; overloaded constructors only
198 -- behave differently when called, not when used for
200 (_, record_ty) = splitFunTy con_tau
202 -- Con is syntactically constrained to be a data constructor
203 ASSERT( maybeToBool (maybeAppDataTyCon record_ty) )
205 mapAndUnzipTc (do_bind record_ty) rpats `thenTc` \ (rpats', lies) ->
207 returnTc (RecPat con_id record_ty rpats',
212 do_bind expected_record_ty (field_label, rhs_pat, pun_flag)
213 = tcLookupGlobalValue field_label `thenNF_Tc` \ sel_id ->
214 tcInstId sel_id `thenNF_Tc` \ (_, _, tau) ->
216 -- Record selectors all have type
217 -- forall a1..an. T a1 .. an -> tau
218 ASSERT( maybeToBool (getFunTy_maybe tau) )
220 -- Selector must have type RecordType -> FieldType
221 Just (record_ty, field_ty) = getFunTy_maybe tau
223 tcAddErrCtxt (recordLabel field_label) (
224 unifyTauTy expected_record_ty record_ty
226 tcPat rhs_pat `thenTc` \ (rhs_pat', lie, rhs_ty) ->
227 tcAddErrCtxt (recordRhs field_label rhs_pat) (
228 unifyTauTy field_ty rhs_ty
230 returnTc ((sel_id, rhs_pat', pun_flag), lie)
233 %************************************************************************
235 \subsection{Non-overloaded literals}
237 %************************************************************************
240 tcPat (LitPatIn lit@(HsChar str))
241 = returnTc (LitPat lit charTy, emptyLIE, charTy)
243 tcPat (LitPatIn lit@(HsString str))
244 = tcLookupGlobalValueByKey eqClassOpKey `thenNF_Tc` \ sel_id ->
245 newMethod (LiteralOrigin lit)
246 (RealId sel_id) [stringTy] `thenNF_Tc` \ (lie, eq_id) ->
248 comp_op = HsApp (HsVar eq_id) (HsLitOut lit stringTy)
250 returnTc (NPat lit stringTy comp_op, lie, stringTy)
252 tcPat (LitPatIn lit@(HsIntPrim _))
253 = returnTc (LitPat lit intPrimTy, emptyLIE, intPrimTy)
254 tcPat (LitPatIn lit@(HsCharPrim _))
255 = returnTc (LitPat lit charPrimTy, emptyLIE, charPrimTy)
256 tcPat (LitPatIn lit@(HsStringPrim _))
257 = returnTc (LitPat lit addrPrimTy, emptyLIE, addrPrimTy)
258 tcPat (LitPatIn lit@(HsFloatPrim _))
259 = returnTc (LitPat lit floatPrimTy, emptyLIE, floatPrimTy)
260 tcPat (LitPatIn lit@(HsDoublePrim _))
261 = returnTc (LitPat lit doublePrimTy, emptyLIE, doublePrimTy)
264 %************************************************************************
266 \subsection{Overloaded patterns: int literals and \tr{n+k} patterns}
268 %************************************************************************
271 tcPat (LitPatIn lit@(HsInt i))
272 = newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ tyvar_ty ->
273 newOverloadedLit origin
274 (OverloadedIntegral i) tyvar_ty `thenNF_Tc` \ (lie1, over_lit_id) ->
276 tcLookupGlobalValueByKey eqClassOpKey `thenNF_Tc` \ eq_sel_id ->
277 newMethod origin (RealId eq_sel_id) [tyvar_ty] `thenNF_Tc` \ (lie2, eq_id) ->
279 returnTc (NPat lit tyvar_ty (HsApp (HsVar eq_id)
280 (HsVar over_lit_id)),
284 origin = LiteralOrigin lit
286 tcPat (LitPatIn lit@(HsFrac f))
287 = newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ tyvar_ty ->
288 newOverloadedLit origin
289 (OverloadedFractional f) tyvar_ty `thenNF_Tc` \ (lie1, over_lit_id) ->
291 tcLookupGlobalValueByKey eqClassOpKey `thenNF_Tc` \ eq_sel_id ->
292 newMethod origin (RealId eq_sel_id) [tyvar_ty] `thenNF_Tc` \ (lie2, eq_id) ->
294 returnTc (NPat lit tyvar_ty (HsApp (HsVar eq_id)
295 (HsVar over_lit_id)),
299 origin = LiteralOrigin lit
301 tcPat (LitPatIn lit@(HsLitLit s))
302 = error "tcPat: can't handle ``literal-literal'' patterns"
305 %************************************************************************
307 \subsection{Lists of patterns}
309 %************************************************************************
312 tcPats :: [RenamedPat] -> TcM s ([TcPat s], LIE s, [TcType s])
314 tcPats [] = returnTc ([], emptyLIE, [])
317 = tcPat pat `thenTc` \ (pat', lie, ty) ->
318 tcPats pats `thenTc` \ (pats', lie', tys) ->
320 returnTc (pat':pats', plusLIE lie lie', ty:tys)
323 @matchConArgTys@ grabs the signature of the data constructor, and
324 unifies the actual args against the expected ones.
327 matchConArgTys :: RnName -> [TcType s] -> TcM s (Id, TcType s)
329 matchConArgTys con arg_tys
330 = tcLookupGlobalValue con `thenNF_Tc` \ con_id ->
331 tcInstId con_id `thenNF_Tc` \ (_, _, con_tau) ->
332 -- Ignore the con_theta; overloaded constructors only
333 -- behave differently when called, not when used for
336 (con_args, con_result) = splitFunTy con_tau
337 con_arity = length con_args
338 no_of_args = length arg_tys
340 checkTc (con_arity == no_of_args)
341 (arityErr "Constructor" con_id con_arity no_of_args) `thenTc_`
343 unifyTauTyLists arg_tys con_args `thenTc_`
344 returnTc (con_id, con_result)
348 % =================================================
353 patCtxt pat sty = ppHang (ppStr "In the pattern:") 4 (ppr sty pat)
355 recordLabel field_label sty
356 = ppHang (ppBesides [ppStr "When matching record field", ppr sty field_label])
357 4 (ppBesides [ppStr "with its immediately enclosing constructor"])
359 recordRhs field_label pat sty
360 = ppHang (ppStr "In the record field pattern")
361 4 (ppSep [ppr sty field_label, ppStr "=", ppr sty pat])