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, 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 PprStyle--ToDo:rm
37 import RnHsSyn ( RnName{-instance Outputable-} )
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 )
48 import Util ( assertPanic, panic{-ToDo:rm-} )
52 tcPat :: RenamedPat -> TcM s (TcPat s, LIE s, TcType s)
55 %************************************************************************
57 \subsection{Variables, wildcards, lazy pats, as-pats}
59 %************************************************************************
63 = tcLookupLocalValueOK ("tcPat1:"++ppShow 80 (ppr PprDebug name)) name `thenNF_Tc` \ id ->
64 returnTc (VarPat (TcId id), emptyLIE, idType id)
67 = tcPat pat `thenTc` \ (pat', lie, ty) ->
68 returnTc (LazyPat pat', lie, ty)
70 tcPat pat_in@(AsPatIn name pat)
71 = tcLookupLocalValueOK "tcPat2" name `thenNF_Tc` \ id ->
72 tcPat pat `thenTc` \ (pat', lie, ty) ->
73 tcAddErrCtxt (patCtxt pat_in) $
74 unifyTauTy (idType id) ty `thenTc_`
75 returnTc (AsPat (TcId id) pat', lie, ty)
78 = newTyVarTy mkTypeKind `thenNF_Tc` \ tyvar_ty ->
79 returnTc (WildPat tyvar_ty, emptyLIE, tyvar_ty)
82 = tcPat (negate_lit pat)
84 negate_lit (LitPatIn (HsInt i)) = LitPatIn (HsInt (-i))
85 negate_lit (LitPatIn (HsFrac f)) = LitPatIn (HsFrac (-f))
86 negate_lit _ = panic "TcPat:negate_pat"
88 tcPat (ParPatIn parend_pat)
92 %************************************************************************
94 \subsection{Explicit lists and tuples}
96 %************************************************************************
99 tcPat pat_in@(ListPatIn pats)
100 = tcPats pats `thenTc` \ (pats', lie, tys) ->
101 newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ tyvar_ty ->
102 tcAddErrCtxt (patCtxt pat_in) $
103 unifyTauTyList (tyvar_ty:tys) `thenTc_`
105 returnTc (ListPat tyvar_ty pats', lie, mkListTy tyvar_ty)
107 tcPat pat_in@(TuplePatIn pats)
111 tcPats pats `thenTc` \ (pats', lie, tys) ->
113 -- Make sure we record that the tuples can only contain boxed types
114 newTyVarTys arity mkBoxedTypeKind `thenNF_Tc` \ tyvar_tys ->
116 tcAddErrCtxt (patCtxt pat_in) $
117 unifyTauTyLists tyvar_tys tys `thenTc_`
119 -- possibly do the "make all tuple-pats irrefutable" test:
121 unmangled_result = TuplePat pats'
123 -- Under flag control turn a pattern (x,y,z) into ~(x,y,z)
124 -- so that we can experiment with lazy tuple-matching.
125 -- This is a pretty odd place to make the switch, but
126 -- it was easy to do.
128 possibly_mangled_result
129 = if opt_IrrefutableTuples
130 then LazyPat unmangled_result
131 else unmangled_result
133 -- ToDo: IrrefutableEverything
135 returnTc (possibly_mangled_result, lie, mkTupleTy arity tys)
138 %************************************************************************
140 \subsection{Other constructors}
142 %************************************************************************
144 Constructor patterns are a little fun:
147 typecheck the arguments
149 look up the constructor
151 specialise its type (ignore the translation this produces)
153 check that the context produced by this specialisation is empty
155 get the arguments out of the function type produced from specialising
157 unify them with the types of the patterns
159 back substitute with the type of the result of the constructor
162 ToDo: exploit new representation of constructors to make this more
166 tcPat pat_in@(ConPatIn name pats)
167 = tcPats pats `thenTc` \ (pats', lie, tys) ->
169 tcAddErrCtxt (patCtxt pat_in) $
170 matchConArgTys name tys `thenTc` \ (con_id, data_ty) ->
172 returnTc (ConPat con_id data_ty pats',
176 tcPat pat_in@(ConOpPatIn pat1 op pat2) -- in binary-op form...
177 = tcPat pat1 `thenTc` \ (pat1', lie1, ty1) ->
178 tcPat pat2 `thenTc` \ (pat2', lie2, ty2) ->
180 tcAddErrCtxt (patCtxt pat_in) $
181 matchConArgTys op [ty1,ty2] `thenTc` \ (con_id, data_ty) ->
183 returnTc (ConOpPat pat1' con_id pat2' data_ty,
188 %************************************************************************
192 %************************************************************************
195 tcPat pat_in@(RecPatIn name rpats)
196 = tcLookupGlobalValue name `thenNF_Tc` \ con_id ->
197 tcInstId con_id `thenNF_Tc` \ (_, _, con_tau) ->
199 -- Ignore the con_theta; overloaded constructors only
200 -- behave differently when called, not when used for
202 (_, record_ty) = splitFunTy con_tau
204 -- Con is syntactically constrained to be a data constructor
205 ASSERT( maybeToBool (maybeAppDataTyCon record_ty) )
207 mapAndUnzipTc (do_bind record_ty) rpats `thenTc` \ (rpats', lies) ->
209 returnTc (RecPat con_id record_ty rpats',
214 do_bind expected_record_ty (field_label, rhs_pat, pun_flag)
215 = tcLookupGlobalValue field_label `thenNF_Tc` \ sel_id ->
216 tcInstId sel_id `thenNF_Tc` \ (_, _, tau) ->
218 -- Record selectors all have type
219 -- forall a1..an. T a1 .. an -> tau
220 ASSERT( maybeToBool (getFunTy_maybe tau) )
222 -- Selector must have type RecordType -> FieldType
223 Just (record_ty, field_ty) = getFunTy_maybe tau
225 tcAddErrCtxt (recordLabel field_label) (
226 unifyTauTy expected_record_ty record_ty
228 tcPat rhs_pat `thenTc` \ (rhs_pat', lie, rhs_ty) ->
229 tcAddErrCtxt (recordRhs field_label rhs_pat) (
230 unifyTauTy field_ty rhs_ty
232 returnTc ((sel_id, rhs_pat', pun_flag), lie)
235 %************************************************************************
237 \subsection{Non-overloaded literals}
239 %************************************************************************
242 tcPat (LitPatIn lit@(HsChar str))
243 = returnTc (LitPat lit charTy, emptyLIE, charTy)
245 tcPat (LitPatIn lit@(HsString str))
246 = tcLookupGlobalValueByKey eqClassOpKey `thenNF_Tc` \ sel_id ->
247 newMethod (LiteralOrigin lit)
248 (RealId sel_id) [stringTy] `thenNF_Tc` \ (lie, eq_id) ->
250 comp_op = HsApp (HsVar eq_id) (HsLitOut lit stringTy)
252 returnTc (NPat lit stringTy comp_op, lie, stringTy)
254 tcPat (LitPatIn lit@(HsIntPrim _))
255 = returnTc (LitPat lit intPrimTy, emptyLIE, intPrimTy)
256 tcPat (LitPatIn lit@(HsCharPrim _))
257 = returnTc (LitPat lit charPrimTy, emptyLIE, charPrimTy)
258 tcPat (LitPatIn lit@(HsStringPrim _))
259 = returnTc (LitPat lit addrPrimTy, emptyLIE, addrPrimTy)
260 tcPat (LitPatIn lit@(HsFloatPrim _))
261 = returnTc (LitPat lit floatPrimTy, emptyLIE, floatPrimTy)
262 tcPat (LitPatIn lit@(HsDoublePrim _))
263 = returnTc (LitPat lit doublePrimTy, emptyLIE, doublePrimTy)
266 %************************************************************************
268 \subsection{Overloaded patterns: int literals and \tr{n+k} patterns}
270 %************************************************************************
273 tcPat (LitPatIn lit@(HsInt i))
274 = newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ tyvar_ty ->
275 newOverloadedLit origin
276 (OverloadedIntegral i) tyvar_ty `thenNF_Tc` \ (lie1, over_lit_id) ->
278 tcLookupGlobalValueByKey eqClassOpKey `thenNF_Tc` \ eq_sel_id ->
279 newMethod origin (RealId eq_sel_id) [tyvar_ty] `thenNF_Tc` \ (lie2, eq_id) ->
281 returnTc (NPat lit tyvar_ty (HsApp (HsVar eq_id)
282 (HsVar over_lit_id)),
286 origin = LiteralOrigin lit
288 tcPat (LitPatIn lit@(HsFrac f))
289 = newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ tyvar_ty ->
290 newOverloadedLit origin
291 (OverloadedFractional f) tyvar_ty `thenNF_Tc` \ (lie1, over_lit_id) ->
293 tcLookupGlobalValueByKey eqClassOpKey `thenNF_Tc` \ eq_sel_id ->
294 newMethod origin (RealId eq_sel_id) [tyvar_ty] `thenNF_Tc` \ (lie2, eq_id) ->
296 returnTc (NPat lit tyvar_ty (HsApp (HsVar eq_id)
297 (HsVar over_lit_id)),
301 origin = LiteralOrigin lit
303 tcPat (LitPatIn lit@(HsLitLit s))
304 = error "tcPat: can't handle ``literal-literal'' patterns"
307 %************************************************************************
309 \subsection{Lists of patterns}
311 %************************************************************************
314 tcPats :: [RenamedPat] -> TcM s ([TcPat s], LIE s, [TcType s])
316 tcPats [] = returnTc ([], emptyLIE, [])
319 = tcPat pat `thenTc` \ (pat', lie, ty) ->
320 tcPats pats `thenTc` \ (pats', lie', tys) ->
322 returnTc (pat':pats', plusLIE lie lie', ty:tys)
325 @matchConArgTys@ grabs the signature of the data constructor, and
326 unifies the actual args against the expected ones.
329 matchConArgTys :: RnName -> [TcType s] -> TcM s (Id, TcType s)
331 matchConArgTys con arg_tys
332 = tcLookupGlobalValue con `thenNF_Tc` \ con_id ->
333 tcInstId con_id `thenNF_Tc` \ (_, _, con_tau) ->
334 -- Ignore the con_theta; overloaded constructors only
335 -- behave differently when called, not when used for
338 (con_args, con_result) = splitFunTy con_tau
339 con_arity = length con_args
340 no_of_args = length arg_tys
342 checkTc (con_arity == no_of_args)
343 (arityErr "Constructor" con_id con_arity no_of_args) `thenTc_`
345 unifyTauTyLists arg_tys con_args `thenTc_`
346 returnTc (con_id, con_result)
350 % =================================================
355 patCtxt pat sty = ppHang (ppStr "In the pattern:") 4 (ppr sty pat)
357 recordLabel field_label sty
358 = ppHang (ppBesides [ppStr "When matching record field", ppr sty field_label])
359 4 (ppBesides [ppStr "with its immediately enclosing constructor"])
361 recordRhs field_label pat sty
362 = ppHang (ppStr "In the record field pattern")
363 4 (ppSep [ppr sty field_label, ppStr "=", ppr sty pat])