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(..) )
20 import Inst ( Inst, OverloadedLit(..), InstOrigin(..),
21 emptyLIE, plusLIE, plusLIEs, LIE(..),
22 newMethod, newOverloadedLit
24 import TcEnv ( tcLookupGlobalValue, tcLookupGlobalValueByKey,
25 tcLookupLocalValueOK, tcGlobalOcc )
26 import TcType ( TcType(..), TcMaybe, tcInstType, newTyVarTy, newTyVarTys )
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 )
35 import PprType ( GenType, GenTyVar )
36 import PrelInfo ( charPrimTy, intPrimTy, floatPrimTy,
37 doublePrimTy, charTy, stringTy, mkListTy,
38 mkTupleTy, addrTy, addrPrimTy )
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 %************************************************************************
82 \subsection{Explicit lists and tuples}
84 %************************************************************************
87 tcPat pat_in@(ListPatIn pats)
88 = tcPats pats `thenTc` \ (pats', lie, tys) ->
89 newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ tyvar_ty ->
90 tcAddErrCtxt (patCtxt pat_in) $
91 unifyTauTyList (tyvar_ty:tys) `thenTc_`
93 returnTc (ListPat tyvar_ty pats', lie, mkListTy tyvar_ty)
95 tcPat pat_in@(TuplePatIn pats)
99 tcPats pats `thenTc` \ (pats', lie, tys) ->
101 -- Make sure we record that the tuples can only contain boxed types
102 newTyVarTys arity mkBoxedTypeKind `thenNF_Tc` \ tyvar_tys ->
104 tcAddErrCtxt (patCtxt pat_in) $
105 unifyTauTyLists tyvar_tys tys `thenTc_`
107 -- possibly do the "make all tuple-pats irrefutable" test:
109 unmangled_result = TuplePat pats'
111 -- Under flag control turn a pattern (x,y,z) into ~(x,y,z)
112 -- so that we can experiment with lazy tuple-matching.
113 -- This is a pretty odd place to make the switch, but
114 -- it was easy to do.
116 possibly_mangled_result
117 = if opt_IrrefutableTuples
118 then LazyPat unmangled_result
119 else unmangled_result
121 -- ToDo: IrrefutableEverything
123 returnTc (possibly_mangled_result, lie, mkTupleTy arity tys)
126 %************************************************************************
128 \subsection{Other constructors}
130 %************************************************************************
132 Constructor patterns are a little fun:
135 typecheck the arguments
137 look up the constructor
139 specialise its type (ignore the translation this produces)
141 check that the context produced by this specialisation is empty
143 get the arguments out of the function type produced from specialising
145 unify them with the types of the patterns
147 back substitute with the type of the result of the constructor
150 ToDo: exploit new representation of constructors to make this more
154 tcPat pat_in@(ConPatIn name pats)
155 = tcPats pats `thenTc` \ (pats', lie, tys) ->
157 tcAddErrCtxt (patCtxt pat_in) $
158 matchConArgTys name tys `thenTc` \ (con_id, data_ty) ->
160 returnTc (ConPat con_id data_ty pats',
164 tcPat pat_in@(ConOpPatIn pat1 op pat2) -- & in binary-op form...
165 = tcPat pat1 `thenTc` \ (pat1', lie1, ty1) ->
166 tcPat pat2 `thenTc` \ (pat2', lie2, ty2) ->
168 tcAddErrCtxt (patCtxt pat_in) $
169 matchConArgTys op [ty1,ty2] `thenTc` \ (con_id, data_ty) ->
171 returnTc (ConOpPat pat1' con_id pat2' data_ty,
176 %************************************************************************
180 %************************************************************************
183 tcPat pat_in@(RecPatIn name rpats)
184 = tcGlobalOcc name `thenNF_Tc` \ (con_id, _, con_rho) ->
186 (_, con_tau) = splitRhoTy con_rho
187 -- Ignore the con_theta; overloaded constructors only
188 -- behave differently when called, not when used for
190 (_, record_ty) = splitFunTy con_tau
192 -- Con is syntactically constrained to be a data constructor
193 ASSERT( maybeToBool (maybeAppDataTyCon record_ty ) )
195 mapAndUnzipTc (do_bind record_ty) rpats `thenTc` \ (rpats', lies) ->
197 returnTc (panic "tcPat:RecPatIn:avoid type errors"{-RecPat con_id record_ty rpats',
202 do_bind expected_record_ty (field_label, rhs_pat, pun_flag)
203 = tcGlobalOcc field_label `thenNF_Tc` \ (sel_id, _, tau) ->
205 -- Record selectors all have type
206 -- forall a1..an. T a1 .. an -> tau
207 ASSERT( maybeToBool (getFunTy_maybe tau) )
209 -- Selector must have type RecordType -> FieldType
210 Just (record_ty, field_ty) = getFunTy_maybe tau
212 tcAddErrCtxt (recordLabel field_label) (
213 unifyTauTy expected_record_ty record_ty
215 tcPat rhs_pat `thenTc` \ (rhs_pat', lie, rhs_ty) ->
216 tcAddErrCtxt (recordRhs field_label rhs_pat) (
217 unifyTauTy field_ty rhs_ty
219 returnTc ((sel_id, rhs_pat', pun_flag), lie)
222 %************************************************************************
224 \subsection{Non-overloaded literals}
226 %************************************************************************
229 tcPat (LitPatIn lit@(HsChar str))
230 = returnTc (LitPat lit charTy, emptyLIE, charTy)
232 tcPat (LitPatIn lit@(HsString str))
233 = tcLookupGlobalValueByKey eqClassOpKey `thenNF_Tc` \ sel_id ->
234 newMethod (LiteralOrigin lit)
235 (RealId sel_id) [stringTy] `thenNF_Tc` \ (lie, eq_id) ->
237 comp_op = HsApp (HsVar eq_id) (HsLitOut lit stringTy)
239 returnTc (NPat lit stringTy comp_op, lie, stringTy)
241 tcPat (LitPatIn lit@(HsIntPrim _))
242 = returnTc (LitPat lit intPrimTy, emptyLIE, intPrimTy)
243 tcPat (LitPatIn lit@(HsCharPrim _))
244 = returnTc (LitPat lit charPrimTy, emptyLIE, charPrimTy)
245 tcPat (LitPatIn lit@(HsStringPrim _))
246 = returnTc (LitPat lit addrPrimTy, emptyLIE, addrPrimTy)
247 tcPat (LitPatIn lit@(HsFloatPrim _))
248 = returnTc (LitPat lit floatPrimTy, emptyLIE, floatPrimTy)
249 tcPat (LitPatIn lit@(HsDoublePrim _))
250 = returnTc (LitPat lit doublePrimTy, emptyLIE, doublePrimTy)
253 %************************************************************************
255 \subsection{Overloaded patterns: int literals and \tr{n+k} patterns}
257 %************************************************************************
260 tcPat (LitPatIn lit@(HsInt i))
261 = newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ tyvar_ty ->
262 newOverloadedLit origin
263 (OverloadedIntegral i) tyvar_ty `thenNF_Tc` \ (lie1, over_lit_id) ->
265 tcLookupGlobalValueByKey eqClassOpKey `thenNF_Tc` \ eq_sel_id ->
266 newMethod origin (RealId eq_sel_id) [tyvar_ty] `thenNF_Tc` \ (lie2, eq_id) ->
268 returnTc (NPat lit tyvar_ty (HsApp (HsVar eq_id)
269 (HsVar over_lit_id)),
273 origin = LiteralOrigin lit
275 tcPat (LitPatIn lit@(HsFrac f))
276 = newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ tyvar_ty ->
277 newOverloadedLit origin
278 (OverloadedFractional f) tyvar_ty `thenNF_Tc` \ (lie1, over_lit_id) ->
280 tcLookupGlobalValueByKey eqClassOpKey `thenNF_Tc` \ eq_sel_id ->
281 newMethod origin (RealId eq_sel_id) [tyvar_ty] `thenNF_Tc` \ (lie2, eq_id) ->
283 returnTc (NPat lit tyvar_ty (HsApp (HsVar eq_id)
284 (HsVar over_lit_id)),
288 origin = LiteralOrigin lit
290 tcPat (LitPatIn lit@(HsLitLit s))
291 = error "tcPat: can't handle ``literal-literal'' patterns"
294 %************************************************************************
296 \subsection{Lists of patterns}
298 %************************************************************************
301 tcPats :: [RenamedPat] -> TcM s ([TcPat s], LIE s, [TcType s])
303 tcPats [] = returnTc ([], emptyLIE, [])
306 = tcPat pat `thenTc` \ (pat', lie, ty) ->
307 tcPats pats `thenTc` \ (pats', lie', tys) ->
309 returnTc (pat':pats', plusLIE lie lie', ty:tys)
312 @matchConArgTys@ grabs the signature of the data constructor, and
313 unifies the actual args against the expected ones.
316 matchConArgTys :: Name -> [TcType s] -> TcM s (Id, TcType s)
318 matchConArgTys con arg_tys
319 = tcGlobalOcc con `thenNF_Tc` \ (con_id, _, con_rho) ->
321 (con_theta, con_tau) = splitRhoTy con_rho
322 -- Ignore the con_theta; overloaded constructors only
323 -- behave differently when called, not when used for
326 (con_args, con_result) = splitFunTy con_tau
327 con_arity = length con_args
328 no_of_args = length arg_tys
330 checkTc (con_arity == no_of_args)
331 (arityErr "Constructor" con_id con_arity no_of_args) `thenTc_`
333 unifyTauTyLists arg_tys con_args `thenTc_`
334 returnTc (con_id, con_result)
338 % =================================================
343 patCtxt pat sty = ppHang (ppStr "In the pattern:") 4 (ppr sty pat)
345 recordLabel field_label sty
346 = ppHang (ppBesides [ppStr "When matching record field", ppr sty field_label])
347 4 (ppBesides [ppStr "with its immediately enclosing constructor"])
349 recordRhs field_label pat sty
350 = ppHang (ppStr "In the record field pattern")
351 4 (ppSep [ppr sty field_label, ppStr "=", ppr sty pat])