[project @ 2002-04-02 13:21:36 by simonpj]
[ghc-hetmet.git] / ghc / compiler / typecheck / TcPat.lhs
1 %
2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
3 %
4 \section[TcPat]{Typechecking patterns}
5
6 \begin{code}
7 module TcPat ( tcPat, tcMonoPatBndr, tcSubPat,
8                badFieldCon, polyPatSig
9   ) where
10
11 #include "HsVersions.h"
12
13 import HsSyn            ( InPat(..), OutPat(..), HsLit(..), HsOverLit(..), HsExpr(..) )
14 import RnHsSyn          ( RenamedPat )
15 import TcHsSyn          ( TcPat, TcId, simpleHsLitTy )
16
17 import TcMonad
18 import Inst             ( InstOrigin(..),
19                           emptyLIE, plusLIE, LIE, mkLIE, unitLIE, instToId, isEmptyLIE,
20                           newMethod, newOverloadedLit, newDicts, tcInstDataCon
21                         )
22 import Id               ( mkLocalId, mkSysLocal )
23 import Name             ( Name )
24 import FieldLabel       ( fieldLabelName )
25 import TcEnv            ( tcLookupClass, tcLookupDataCon, tcLookupGlobalId, tcLookupId )
26 import TcMType          ( newTyVarTy, zapToType )
27 import TcType           ( TcType, TcTyVar, TcSigmaType, 
28                           mkClassPred, liftedTypeKind )
29 import TcUnify          ( tcSubOff, TcHoleType, 
30                           unifyTauTy, unifyListTy, unifyPArrTy, unifyTupleTy,  
31                           mkCoercion, idCoercion, isIdCoercion,
32                           (<$>), PatCoFn )
33 import TcMonoType       ( tcHsSigType, UserTypeCtxt(..) )
34
35 import TysWiredIn       ( stringTy )
36 import CmdLineOpts      ( opt_IrrefutableTuples )
37 import DataCon          ( dataConFieldLabels, dataConSourceArity )
38 import PrelNames        ( eqStringName, eqName, geName, cCallableClassName )
39 import BasicTypes       ( isBoxed )
40 import Bag
41 import Outputable
42 \end{code}
43
44
45 %************************************************************************
46 %*                                                                      *
47 \subsection{Variable patterns}
48 %*                                                                      *
49 %************************************************************************
50
51 \begin{code}
52 type BinderChecker = Name -> TcSigmaType -> TcM (PatCoFn, LIE, TcId)
53                         -- How to construct a suitable (monomorphic)
54                         -- Id for variables found in the pattern
55                         -- The TcSigmaType is the expected type 
56                         -- from the pattern context
57
58 -- The Id may have a sigma type (e.g. f (x::forall a. a->a))
59 -- so we want to *create* it during pattern type checking.
60 -- We don't want to make Ids first with a type-variable type
61 -- and then unify... becuase we can't unify a sigma type with a type variable.
62
63 tcMonoPatBndr :: BinderChecker
64   -- This is the right function to pass to tcPat when 
65   -- we're looking at a lambda-bound pattern, 
66   -- so there's no polymorphic guy to worry about
67
68 tcMonoPatBndr binder_name pat_ty 
69   = zapToType pat_ty    `thenNF_Tc` \ pat_ty' ->
70         -- If there are *no constraints* on the pattern type, we
71         -- revert to good old H-M typechecking, making
72         -- the type of the binder into an *ordinary* 
73         -- type variable.  We find out if there are no constraints
74         -- by seeing if we are given an "open hole" as our info.
75         -- What we are trying to avoid here is giving a binder
76         -- a type that is a 'hole'.  The only place holes should
77         -- appear is as an argument to tcPat and tcExpr/tcMonoExpr.
78
79     returnTc (idCoercion, emptyLIE, mkLocalId binder_name pat_ty')
80 \end{code}
81
82
83 %************************************************************************
84 %*                                                                      *
85 \subsection{Typechecking patterns}
86 %*                                                                      *
87 %************************************************************************
88
89 \begin{code}
90 tcPat :: BinderChecker
91       -> RenamedPat
92
93       -> TcHoleType     -- Expected type derived from the context
94                         --      In the case of a function with a rank-2 signature,
95                         --      this type might be a forall type.
96
97       -> TcM (TcPat, 
98                 LIE,                    -- Required by n+k and literal pats
99                 Bag TcTyVar,    -- TyVars bound by the pattern
100                                         --      These are just the existentially-bound ones.
101                                         --      Any tyvars bound by *type signatures* in the
102                                         --      patterns are brought into scope before we begin.
103                 Bag (Name, TcId),       -- Ids bound by the pattern, along with the Name under
104                                         --      which it occurs in the pattern
105                                         --      The two aren't the same because we conjure up a new
106                                         --      local name for each variable.
107                 LIE)                    -- Dicts or methods [see below] bound by the pattern
108                                         --      from existential constructor patterns
109 \end{code}
110
111
112 %************************************************************************
113 %*                                                                      *
114 \subsection{Variables, wildcards, lazy pats, as-pats}
115 %*                                                                      *
116 %************************************************************************
117
118 \begin{code}
119 tcPat tc_bndr pat@(TypePatIn ty) pat_ty
120   = failWithTc (badTypePat pat)
121
122 tcPat tc_bndr (VarPatIn name) pat_ty
123   = tc_bndr name pat_ty                         `thenTc` \ (co_fn, lie_req, bndr_id) ->
124     returnTc (co_fn <$> VarPat bndr_id, lie_req,
125               emptyBag, unitBag (name, bndr_id), emptyLIE)
126
127 tcPat tc_bndr (LazyPatIn pat) pat_ty
128   = tcPat tc_bndr pat pat_ty            `thenTc` \ (pat', lie_req, tvs, ids, lie_avail) ->
129     returnTc (LazyPat pat', lie_req, tvs, ids, lie_avail)
130
131 tcPat tc_bndr pat_in@(AsPatIn name pat) pat_ty
132   = tc_bndr name pat_ty                 `thenTc` \ (co_fn, lie_req1, bndr_id) ->
133     tcPat tc_bndr pat pat_ty            `thenTc` \ (pat', lie_req2, tvs, ids, lie_avail) ->
134     returnTc (co_fn <$> (AsPat bndr_id pat'), lie_req1 `plusLIE` lie_req2, 
135               tvs, (name, bndr_id) `consBag` ids, lie_avail)
136
137 tcPat tc_bndr WildPatIn pat_ty
138   = zapToType pat_ty                    `thenNF_Tc` \ pat_ty' ->
139         -- We might have an incoming 'hole' type variable; no annotation
140         -- so zap it to a type.  Rather like tcMonoPatBndr.
141     returnTc (WildPat pat_ty', emptyLIE, emptyBag, emptyBag, emptyLIE)
142
143 tcPat tc_bndr (ParPatIn parend_pat) pat_ty
144   = tcPat tc_bndr parend_pat pat_ty
145
146 tcPat tc_bndr pat_in@(SigPatIn pat sig) pat_ty
147   = tcAddErrCtxt (patCtxt pat_in)       $
148     tcHsSigType PatSigCtxt sig          `thenTc` \ sig_ty ->
149     tcSubPat sig_ty pat_ty              `thenTc` \ (co_fn, lie_sig) ->
150     tcPat tc_bndr pat sig_ty            `thenTc` \ (pat', lie_req, tvs, ids, lie_avail) ->
151     returnTc (co_fn <$> pat', lie_req `plusLIE` lie_sig, tvs, ids, lie_avail)
152 \end{code}
153
154
155 %************************************************************************
156 %*                                                                      *
157 \subsection{Explicit lists, parallel arrays, and tuples}
158 %*                                                                      *
159 %************************************************************************
160
161 \begin{code}
162 tcPat tc_bndr pat_in@(ListPatIn pats) pat_ty
163   = tcAddErrCtxt (patCtxt pat_in)               $
164     unifyListTy pat_ty                          `thenTc` \ elem_ty ->
165     tcPats tc_bndr pats (repeat elem_ty)        `thenTc` \ (pats', lie_req, tvs, ids, lie_avail) ->
166     returnTc (ListPat elem_ty pats', lie_req, tvs, ids, lie_avail)
167
168 tcPat tc_bndr pat_in@(PArrPatIn pats) pat_ty
169   = tcAddErrCtxt (patCtxt pat_in)               $
170     unifyPArrTy pat_ty                          `thenTc` \ elem_ty ->
171     tcPats tc_bndr pats (repeat elem_ty)        `thenTc` \ (pats', lie_req, tvs, ids, lie_avail) ->
172     returnTc (PArrPat elem_ty pats', lie_req, tvs, ids, lie_avail)
173
174 tcPat tc_bndr pat_in@(TuplePatIn pats boxity) pat_ty
175   = tcAddErrCtxt (patCtxt pat_in)       $
176
177     unifyTupleTy boxity arity pat_ty            `thenTc` \ arg_tys ->
178     tcPats tc_bndr pats arg_tys                 `thenTc` \ (pats', lie_req, tvs, ids, lie_avail) ->
179
180         -- possibly do the "make all tuple-pats irrefutable" test:
181     let
182         unmangled_result = TuplePat pats' boxity
183
184         -- Under flag control turn a pattern (x,y,z) into ~(x,y,z)
185         -- so that we can experiment with lazy tuple-matching.
186         -- This is a pretty odd place to make the switch, but
187         -- it was easy to do.
188
189         possibly_mangled_result
190           | opt_IrrefutableTuples && isBoxed boxity = LazyPat unmangled_result
191           | otherwise                               = unmangled_result
192     in
193     returnTc (possibly_mangled_result, lie_req, tvs, ids, lie_avail)
194   where
195     arity = length pats
196 \end{code}
197
198
199 %************************************************************************
200 %*                                                                      *
201 \subsection{Other constructors}
202 %*                                                                      *
203
204 %************************************************************************
205
206 \begin{code}
207 tcPat tc_bndr pat@(ConPatIn name arg_pats) pat_ty
208   = tcConPat tc_bndr pat name arg_pats pat_ty
209
210 tcPat tc_bndr pat@(ConOpPatIn pat1 op _ pat2) pat_ty
211   = tcConPat tc_bndr pat op [pat1, pat2] pat_ty
212 \end{code}
213
214
215 %************************************************************************
216 %*                                                                      *
217 \subsection{Records}
218 %*                                                                      *
219 %************************************************************************
220
221 \begin{code}
222 tcPat tc_bndr pat@(RecPatIn name rpats) pat_ty
223   = tcAddErrCtxt (patCtxt pat)  $
224
225         -- Check the constructor itself
226     tcConstructor pat name              `thenTc` \ (data_con, lie_req1, ex_tvs, ex_dicts, lie_avail1, arg_tys, con_res_ty) ->
227
228         -- Check overall type matches (c.f. tcConPat)
229     tcSubPat con_res_ty pat_ty          `thenTc` \ (co_fn, lie_req2) ->
230     let
231         -- Don't use zipEqual! If the constructor isn't really a record, then
232         -- dataConFieldLabels will be empty (and each field in the pattern
233         -- will generate an error below).
234         field_tys = zip (map fieldLabelName (dataConFieldLabels data_con))
235                         arg_tys
236     in
237
238         -- Check the fields
239     tc_fields field_tys rpats           `thenTc` \ (rpats', lie_req3, tvs, ids, lie_avail2) ->
240
241     returnTc (RecPat data_con pat_ty ex_tvs ex_dicts rpats',
242               lie_req1 `plusLIE` lie_req2 `plusLIE` lie_req3,
243               listToBag ex_tvs `unionBags` tvs,
244               ids,
245               lie_avail1 `plusLIE` lie_avail2)
246
247   where
248     tc_fields field_tys []
249       = returnTc ([], emptyLIE, emptyBag, emptyBag, emptyLIE)
250
251     tc_fields field_tys ((field_label, rhs_pat, pun_flag) : rpats)
252       = tc_fields field_tys rpats       `thenTc` \ (rpats', lie_req1, tvs1, ids1, lie_avail1) ->
253
254         (case [ty | (f,ty) <- field_tys, f == field_label] of
255
256                 -- No matching field; chances are this field label comes from some
257                 -- other record type (or maybe none).  As well as reporting an
258                 -- error we still want to typecheck the pattern, principally to
259                 -- make sure that all the variables it binds are put into the
260                 -- environment, else the type checker crashes later:
261                 --      f (R { foo = (a,b) }) = a+b
262                 -- If foo isn't one of R's fields, we don't want to crash when
263                 -- typechecking the "a+b".
264            [] -> addErrTc (badFieldCon name field_label)        `thenNF_Tc_` 
265                  newTyVarTy liftedTypeKind                      `thenNF_Tc_` 
266                  returnTc (error "Bogus selector Id", pat_ty)
267
268                 -- The normal case, when the field comes from the right constructor
269            (pat_ty : extras) -> 
270                 ASSERT( null extras )
271                 tcLookupGlobalId field_label                    `thenNF_Tc` \ sel_id ->
272                 returnTc (sel_id, pat_ty)
273         )                                                       `thenTc` \ (sel_id, pat_ty) ->
274
275         tcPat tc_bndr rhs_pat pat_ty    `thenTc` \ (rhs_pat', lie_req2, tvs2, ids2, lie_avail2) ->
276
277         returnTc ((sel_id, rhs_pat', pun_flag) : rpats',
278                   lie_req1 `plusLIE` lie_req2,
279                   tvs1 `unionBags` tvs2,
280                   ids1 `unionBags` ids2,
281                   lie_avail1 `plusLIE` lie_avail2)
282 \end{code}
283
284 %************************************************************************
285 %*                                                                      *
286 \subsection{Literals}
287 %*                                                                      *
288 %************************************************************************
289
290 \begin{code}
291 tcPat tc_bndr (LitPatIn lit@(HsLitLit s _)) pat_ty 
292         -- cf tcExpr on LitLits
293   = tcLookupClass cCallableClassName            `thenNF_Tc` \ cCallableClass ->
294     newDicts (LitLitOrigin (_UNPK_ s))
295              [mkClassPred cCallableClass [pat_ty]]      `thenNF_Tc` \ dicts ->
296     returnTc (LitPat (HsLitLit s pat_ty) pat_ty, mkLIE dicts, emptyBag, emptyBag, emptyLIE)
297
298 tcPat tc_bndr pat@(LitPatIn lit@(HsString _)) pat_ty
299   = unifyTauTy pat_ty stringTy                  `thenTc_` 
300     tcLookupGlobalId eqStringName               `thenNF_Tc` \ eq_id ->
301     returnTc (NPat lit stringTy (HsVar eq_id `HsApp` HsLit lit), 
302               emptyLIE, emptyBag, emptyBag, emptyLIE)
303
304 tcPat tc_bndr (LitPatIn simple_lit) pat_ty
305   = unifyTauTy pat_ty (simpleHsLitTy simple_lit)                `thenTc_` 
306     returnTc (LitPat simple_lit pat_ty, emptyLIE, emptyBag, emptyBag, emptyLIE)
307
308 tcPat tc_bndr pat@(NPatIn over_lit) pat_ty
309   = newOverloadedLit (PatOrigin pat) over_lit pat_ty    `thenNF_Tc` \ (over_lit_expr, lie1) ->
310     tcLookupGlobalId eqName                             `thenNF_Tc` \ eq_sel_id ->
311     newMethod origin eq_sel_id [pat_ty]                 `thenNF_Tc` \ eq ->
312
313     returnTc (NPat lit' pat_ty (HsApp (HsVar (instToId eq)) over_lit_expr),
314               lie1 `plusLIE` unitLIE eq,
315               emptyBag, emptyBag, emptyLIE)
316   where
317     origin = PatOrigin pat
318     lit' = case over_lit of
319                 HsIntegral i _   -> HsInteger i
320                 HsFractional f _ -> HsRat f pat_ty
321 \end{code}
322
323 %************************************************************************
324 %*                                                                      *
325 \subsection{n+k patterns}
326 %*                                                                      *
327 %************************************************************************
328
329 \begin{code}
330 tcPat tc_bndr pat@(NPlusKPatIn name lit@(HsIntegral i _) minus_name) pat_ty
331   = tc_bndr name pat_ty                         `thenTc` \ (co_fn, lie1, bndr_id) ->
332         -- The '-' part is re-mappable syntax
333     tcLookupId minus_name                       `thenNF_Tc` \ minus_sel_id ->
334     tcLookupGlobalId geName                     `thenNF_Tc` \ ge_sel_id ->
335     newOverloadedLit origin lit pat_ty          `thenNF_Tc` \ (over_lit_expr, lie2) ->
336     newMethod origin ge_sel_id    [pat_ty]      `thenNF_Tc` \ ge ->
337     newMethod origin minus_sel_id [pat_ty]      `thenNF_Tc` \ minus ->
338
339     returnTc (NPlusKPat bndr_id i pat_ty
340                         (SectionR (HsVar (instToId ge)) over_lit_expr)
341                         (SectionR (HsVar (instToId minus)) over_lit_expr),
342               lie1 `plusLIE` lie2 `plusLIE` mkLIE [ge,minus],
343               emptyBag, unitBag (name, bndr_id), emptyLIE)
344   where
345     origin = PatOrigin pat
346 \end{code}
347
348 %************************************************************************
349 %*                                                                      *
350 \subsection{Lists of patterns}
351 %*                                                                      *
352 %************************************************************************
353
354 Helper functions
355
356 \begin{code}
357 tcPats :: BinderChecker                         -- How to deal with variables
358        -> [RenamedPat] -> [TcType]              -- Excess 'expected types' discarded
359        -> TcM ([TcPat], 
360                  LIE,                           -- Required by n+k and literal pats
361                  Bag TcTyVar,
362                  Bag (Name, TcId),      -- Ids bound by the pattern
363                  LIE)                           -- Dicts bound by the pattern
364
365 tcPats tc_bndr [] tys = returnTc ([], emptyLIE, emptyBag, emptyBag, emptyLIE)
366
367 tcPats tc_bndr (ty:tys) (pat:pats)
368   = tcPat tc_bndr ty pat                `thenTc` \ (pat',  lie_req1, tvs1, ids1, lie_avail1) ->
369     tcPats tc_bndr tys pats     `thenTc` \ (pats', lie_req2, tvs2, ids2, lie_avail2) ->
370
371     returnTc (pat':pats', lie_req1 `plusLIE` lie_req2,
372               tvs1 `unionBags` tvs2, ids1 `unionBags` ids2, 
373               lie_avail1 `plusLIE` lie_avail2)
374 \end{code}
375
376 ------------------------------------------------------
377 \begin{code}
378 tcConstructor pat con_name
379   =     -- Check that it's a constructor
380     tcLookupDataCon con_name            `thenNF_Tc` \ data_con ->
381
382         -- Instantiate it
383     tcInstDataCon (PatOrigin pat) data_con      `thenNF_Tc` \ (_, ex_dicts, arg_tys, result_ty, lie_req, ex_lie, ex_tvs) ->
384
385     returnTc (data_con, lie_req, ex_tvs, ex_dicts, ex_lie, arg_tys, result_ty)
386 \end{code}            
387
388 ------------------------------------------------------
389 \begin{code}
390 tcConPat tc_bndr pat con_name arg_pats pat_ty
391   = tcAddErrCtxt (patCtxt pat)  $
392
393         -- Check the constructor itself
394     tcConstructor pat con_name  `thenTc` \ (data_con, lie_req1, ex_tvs, ex_dicts, lie_avail1, arg_tys, con_res_ty) ->
395
396         -- Check overall type matches.
397         -- The pat_ty might be a for-all type, in which
398         -- case we must instantiate to match
399     tcSubPat con_res_ty pat_ty  `thenTc` \ (co_fn, lie_req2) ->
400
401         -- Check correct arity
402     let
403         con_arity  = dataConSourceArity data_con
404         no_of_args = length arg_pats
405     in
406     checkTc (con_arity == no_of_args)
407             (arityErr "Constructor" data_con con_arity no_of_args)      `thenTc_`
408
409         -- Check arguments
410     tcPats tc_bndr arg_pats arg_tys     `thenTc` \ (arg_pats', lie_req3, tvs, ids, lie_avail2) ->
411
412     returnTc (co_fn <$> ConPat data_con pat_ty ex_tvs ex_dicts arg_pats',
413               lie_req1 `plusLIE` lie_req2 `plusLIE` lie_req3,
414               listToBag ex_tvs `unionBags` tvs,
415               ids,
416               lie_avail1 `plusLIE` lie_avail2)
417 \end{code}
418
419
420 %************************************************************************
421 %*                                                                      *
422 \subsection{Subsumption}
423 %*                                                                      *
424 %************************************************************************
425
426 Example:  
427         f :: (forall a. a->a) -> Int -> Int
428         f (g::Int->Int) y = g y
429 This is ok: the type signature allows fewer callers than
430 the (more general) signature f :: (Int->Int) -> Int -> Int
431 I.e.    (forall a. a->a) <= Int -> Int
432 We end up translating this to:
433         f = \g' :: (forall a. a->a).  let g = g' Int in g' y
434
435 tcSubPat does the work
436         sig_ty is the signature on the pattern itself 
437                 (Int->Int in the example)
438         expected_ty is the type passed inwards from the context
439                 (forall a. a->a in the example)
440
441 \begin{code}
442 tcSubPat :: TcSigmaType -> TcHoleType -> TcM (PatCoFn, LIE)
443
444 tcSubPat sig_ty exp_ty
445  = tcSubOff sig_ty exp_ty               `thenTc` \ (co_fn, lie) ->
446         -- co_fn is a coercion on *expressions*, and we
447         -- need to make a coercion on *patterns*
448    if isIdCoercion co_fn then
449         ASSERT( isEmptyLIE lie )
450         returnNF_Tc (idCoercion, emptyLIE)
451    else
452    tcGetUnique                          `thenNF_Tc` \ uniq ->
453    let
454         arg_id  = mkSysLocal FSLIT("sub") uniq exp_ty
455         the_fn  = DictLam [arg_id] (co_fn <$> HsVar arg_id)
456         pat_co_fn p = SigPat p exp_ty the_fn
457    in
458    returnNF_Tc (mkCoercion pat_co_fn, lie)
459 \end{code}
460
461
462 %************************************************************************
463 %*                                                                      *
464 \subsection{Errors and contexts}
465 %*                                                                      *
466 %************************************************************************
467
468 \begin{code}
469 patCtxt pat = hang (ptext SLIT("When checking the pattern:")) 
470                  4 (ppr pat)
471
472 badFieldCon :: Name -> Name -> SDoc
473 badFieldCon con field
474   = hsep [ptext SLIT("Constructor") <+> quotes (ppr con),
475           ptext SLIT("does not have field"), quotes (ppr field)]
476
477 polyPatSig :: TcType -> SDoc
478 polyPatSig sig_ty
479   = hang (ptext SLIT("Illegal polymorphic type signature in pattern:"))
480          4 (ppr sig_ty)
481
482 badTypePat pat = ptext SLIT("Illegal type pattern") <+> ppr pat
483 \end{code}
484