2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[TcMatches]{Typecheck some @Matches@}
7 module TcMatches ( tcMatchesFun, tcMatchesCase, tcMatchLambda,
8 tcDoStmts, tcStmtsAndThen, tcGRHSs
11 #include "HsVersions.h"
13 import {-# SOURCE #-} TcExpr( tcMonoExpr )
15 import HsSyn ( HsExpr(..), HsBinds(..), Match(..), GRHSs(..), GRHS(..),
16 MonoBinds(..), Stmt(..), HsMatchContext(..), HsStmtContext(..),
17 pprMatch, getMatchLoc, isDoExpr,
18 pprMatchContext, pprStmtContext, pprStmtResultContext,
19 mkMonoBind, collectSigTysFromPats, andMonoBindList
21 import RnHsSyn ( RenamedMatch, RenamedGRHSs, RenamedStmt,
22 RenamedPat, RenamedMatchContext )
23 import TcHsSyn ( TcMatch, TcGRHSs, TcStmt, TcDictBinds, TcHsBinds,
24 TcMonoBinds, TcPat, TcStmt )
27 import TcMonoType ( tcAddScopedTyVars, tcHsSigType, UserTypeCtxt(..) )
28 import Inst ( tcSyntaxName )
29 import TcEnv ( TcId, tcLookupLocalIds, tcLookupId, tcExtendLocalValEnv, tcExtendLocalValEnv2 )
30 import TcPat ( tcPat, tcMonoPatBndr )
31 import TcMType ( newTyVarTy, newTyVarTys, zonkTcType, zapToType )
32 import TcType ( TcType, TcTyVar, tyVarsOfType, tidyOpenTypes, tidyOpenType,
33 mkFunTy, isOverloadedTy, liftedTypeKind, openTypeKind,
34 mkArrowKind, mkAppTy )
35 import TcBinds ( tcBindsAndThen )
36 import TcUnify ( unifyPArrTy,subFunTy, unifyListTy, unifyTauTy,
37 checkSigTyVarsWrt, tcSubExp, isIdCoercion, (<$>) )
38 import TcSimplify ( tcSimplifyCheck, bindInstsOfLocalFuns )
40 import PrelNames ( monadNames, mfixName )
41 import TysWiredIn ( boolTy, mkListTy, mkPArrTy )
42 import Id ( idType, mkSysLocal, mkLocalId )
43 import CoreFVs ( idFreeTyVars )
44 import BasicTypes ( RecFlag(..) )
48 import Util ( isSingleton, lengthExceeds, notNull, zipEqual )
54 %************************************************************************
56 \subsection{tcMatchesFun, tcMatchesCase}
58 %************************************************************************
60 @tcMatchesFun@ typechecks a @[Match]@ list which occurs in a
61 @FunMonoBind@. The second argument is the name of the function, which
62 is used in error messages. It checks that all the equations have the
63 same number of arguments before using @tcMatches@ to do the work.
66 tcMatchesFun :: [(Name,Id)] -- Bindings for the variables bound in this group
68 -> TcType -- Expected type
72 tcMatchesFun xve fun_name expected_ty matches@(first_match:_)
73 = -- Check that they all have the same no of arguments
74 -- Set the location to that of the first equation, so that
75 -- any inter-equation error messages get some vaguely
76 -- sensible location. Note: we have to do this odd
77 -- ann-grabbing, because we don't always have annotations in
78 -- hand when we call tcMatchesFun...
79 addSrcLoc (getMatchLoc first_match) (
80 checkTc (sameNoOfArgs matches)
81 (varyingArgsErr fun_name matches)
84 -- ToDo: Don't use "expected" stuff if there ain't a type signature
85 -- because inconsistency between branches
86 -- may show up as something wrong with the (non-existent) type signature
88 -- No need to zonk expected_ty, because subFunTy does that on the fly
89 tcMatches xve (FunRhs fun_name) matches expected_ty
92 @tcMatchesCase@ doesn't do the argument-count check because the
93 parser guarantees that each equation has exactly one argument.
96 tcMatchesCase :: [RenamedMatch] -- The case alternatives
97 -> TcType -- Type of whole case expressions
98 -> TcM (TcType, -- Inferred type of the scrutinee
99 [TcMatch]) -- Translated alternatives
101 tcMatchesCase matches expr_ty
102 = newTyVarTy openTypeKind `thenM` \ scrut_ty ->
103 tcMatches [] CaseAlt matches (mkFunTy scrut_ty expr_ty) `thenM` \ matches' ->
104 returnM (scrut_ty, matches')
106 tcMatchLambda :: RenamedMatch -> TcType -> TcM TcMatch
107 tcMatchLambda match res_ty = tcMatch [] LambdaExpr match res_ty
112 tcMatches :: [(Name,Id)]
113 -> RenamedMatchContext
118 tcMatches xve ctxt matches expected_ty
119 = -- If there is more than one branch, and expected_ty is a 'hole',
120 -- all branches must be types, not type schemes, otherwise the
121 -- in which we check them would affect the result.
122 (if lengthExceeds matches 1 then
123 zapToType expected_ty
125 returnM expected_ty) `thenM` \ expected_ty' ->
127 mappM (tc_match expected_ty') matches
129 tc_match expected_ty match = tcMatch xve ctxt match expected_ty
133 %************************************************************************
137 %************************************************************************
140 tcMatch :: [(Name,Id)]
141 -> RenamedMatchContext
143 -> TcType -- Expected result-type of the Match.
144 -- Early unification with this guy gives better error messages
145 -- We regard the Match as having type
146 -- (ty1 -> ... -> tyn -> result_ty)
147 -- where there are n patterns.
150 tcMatch xve1 ctxt match@(Match pats maybe_rhs_sig grhss) expected_ty
151 = addSrcLoc (getMatchLoc match) $ -- At one stage I removed this;
152 addErrCtxt (matchCtxt ctxt match) $ -- I'm not sure why, so I put it back
153 tcMatchPats pats expected_ty tc_grhss `thenM` \ (pats', grhss', ex_binds) ->
154 returnM (Match pats' Nothing (glue_on ex_binds grhss'))
158 = tcExtendLocalValEnv2 xve1 $
160 -- Deal with the result signature
161 case maybe_rhs_sig of
162 Nothing -> tcGRHSs ctxt grhss rhs_ty
164 Just sig -> tcAddScopedTyVars [sig] $
165 -- Bring into scope the type variables in the signature
166 tcHsSigType ResSigCtxt sig `thenM` \ sig_ty ->
167 tcGRHSs ctxt grhss sig_ty `thenM` \ grhss' ->
168 tcSubExp rhs_ty sig_ty `thenM` \ co_fn ->
169 returnM (lift_grhss co_fn rhs_ty grhss')
171 -- lift_grhss pushes the coercion down to the right hand sides,
172 -- because there is no convenient place to hang it otherwise.
173 lift_grhss co_fn rhs_ty grhss
174 | isIdCoercion co_fn = grhss
175 lift_grhss co_fn rhs_ty (GRHSs grhss binds ty)
176 = GRHSs (map lift_grhs grhss) binds rhs_ty -- Change the type, since we
178 lift_grhs (GRHS stmts loc) = GRHS (map lift_stmt stmts) loc
180 lift_stmt (ResultStmt e l) = ResultStmt (co_fn <$> e) l
181 lift_stmt stmt = stmt
183 -- glue_on just avoids stupid dross
184 glue_on EmptyBinds grhss = grhss -- The common case
185 glue_on binds1 (GRHSs grhss binds2 ty)
186 = GRHSs grhss (binds1 `ThenBinds` binds2) ty
189 tcGRHSs :: RenamedMatchContext -> RenamedGRHSs
193 tcGRHSs ctxt (GRHSs grhss binds _) expected_ty
194 = tcBindsAndThen glue_on binds (tc_grhss grhss)
196 m_ty = (\ty -> ty, expected_ty)
199 = mappM tc_grhs grhss `thenM` \ grhss' ->
200 returnM (GRHSs grhss' EmptyBinds expected_ty)
202 tc_grhs (GRHS guarded locn)
204 tcStmts (PatGuard ctxt) m_ty guarded `thenM` \ guarded' ->
205 returnM (GRHS guarded' locn)
209 %************************************************************************
211 \subsection{tcMatchPats}
213 %************************************************************************
217 :: [RenamedPat] -> TcType
219 -> TcM ([TcPat], a, TcHsBinds)
220 -- Typecheck the patterns, extend the environment to bind the variables,
221 -- do the thing inside, use any existentially-bound dictionaries to
222 -- discharge parts of the returning LIE, and deal with pattern type
225 tcMatchPats pats expected_ty thing_inside
226 = -- STEP 1: Bring pattern-signature type variables into scope
227 tcAddScopedTyVars (collectSigTysFromPats pats) (
229 -- STEP 2: Typecheck the patterns themselves, gathering all the stuff
230 -- then do the thing inside
231 getLIE (tc_match_pats pats expected_ty thing_inside)
233 ) `thenM` \ ((pats', ex_tvs, ex_ids, ex_lie, result), lie_req) ->
235 -- STEP 4: Check for existentially bound type variables
236 -- Do this *outside* the scope of the tcAddScopedTyVars, else checkSigTyVars
237 -- complains that 'a' is captured by the inscope 'a'! (Test (d) in checkSigTyVars.)
239 -- I'm a bit concerned that lie_req1 from an 'inner' pattern in the list
240 -- might need (via lie_req2) something made available from an 'outer'
241 -- pattern. But it's inconvenient to deal with, and I can't find an example
242 tcCheckExistentialPat ex_tvs ex_ids ex_lie lie_req expected_ty `thenM` \ ex_binds ->
243 -- NB: we *must* pass "expected_ty" not "result_ty" to tcCheckExistentialPat
244 -- For example, we must reject this program:
245 -- data C = forall a. C (a -> Int)
247 -- Here, result_ty will be simply Int, but expected_ty is (a -> Int).
249 returnM (pats', result, mkMonoBind Recursive ex_binds)
251 tc_match_pats [] expected_ty thing_inside
252 = thing_inside expected_ty `thenM` \ answer ->
253 returnM ([], emptyBag, [], [], answer)
255 tc_match_pats (pat:pats) expected_ty thing_inside
256 = subFunTy expected_ty $ \ arg_ty rest_ty ->
257 -- This is the unique place we call subFunTy
258 -- The point is that if expected_y is a "hole", we want
259 -- to make arg_ty and rest_ty as "holes" too.
260 tcPat tcMonoPatBndr pat arg_ty `thenM` \ (pat', ex_tvs, pat_bndrs, ex_lie) ->
262 xve = bagToList pat_bndrs
263 ex_ids = [id | (_, id) <- xve]
264 -- ex_ids is all the pattern-bound Ids, a superset
265 -- of the existential Ids used in checkExistentialPat
267 tcExtendLocalValEnv2 xve $
268 tc_match_pats pats rest_ty thing_inside `thenM` \ (pats', exs_tvs, exs_ids, exs_lie, answer) ->
269 returnM ( pat':pats',
270 ex_tvs `unionBags` exs_tvs,
277 tcCheckExistentialPat :: Bag TcTyVar -- Existentially quantified tyvars bound by pattern
278 -> [TcId] -- Ids bound by this pattern; used
279 -- (a) by bindsInstsOfLocalFuns
280 -- (b) to generate helpful error messages
281 -> [Inst] -- and context
282 -> [Inst] -- Required context
283 -> TcType -- and type of the Match; vars in here must not escape
284 -> TcM TcDictBinds -- LIE to float out and dict bindings
285 tcCheckExistentialPat ex_tvs ex_ids ex_lie lie_req match_ty
286 | isEmptyBag ex_tvs && all not_overloaded ex_ids
287 -- Short cut for case when there are no existentials
288 -- and no polymorphic overloaded variables
289 -- e.g. f :: (forall a. Ord a => a -> a) -> Int -> Int
291 -- Here we must discharge op Methods
292 = ASSERT( null ex_lie )
293 extendLIEs lie_req `thenM_`
294 returnM EmptyMonoBinds
297 = addErrCtxtM (sigPatCtxt tv_list ex_ids match_ty) $
299 -- In case there are any polymorpic, overloaded binders in the pattern
300 -- (which can happen in the case of rank-2 type signatures, or data constructors
301 -- with polymorphic arguments), we must do a bindInstsOfLocalFns here
302 getLIE (bindInstsOfLocalFuns lie_req ex_ids) `thenM` \ (inst_binds, lie) ->
304 -- Deal with overloaded functions bound by the pattern
305 tcSimplifyCheck doc tv_list ex_lie lie `thenM` \ dict_binds ->
306 checkSigTyVarsWrt (tyVarsOfType match_ty) tv_list `thenM_`
308 returnM (dict_binds `AndMonoBinds` inst_binds)
310 doc = text ("existential context of a data constructor")
311 tv_list = bagToList ex_tvs
312 not_overloaded id = not (isOverloadedTy (idType id))
316 %************************************************************************
318 \subsection{@tcDoStmts@ typechecks a {\em list} of do statements}
320 %************************************************************************
323 tcDoStmts :: HsStmtContext Name -> [RenamedStmt] -> [Name] -> TcType
324 -> TcM (TcMonoBinds, [TcStmt], [Id])
325 tcDoStmts PArrComp stmts method_names res_ty
326 = unifyPArrTy res_ty `thenM` \elt_ty ->
327 tcStmts PArrComp (mkPArrTy, elt_ty) stmts `thenM` \ stmts' ->
328 returnM (EmptyMonoBinds, stmts', [{- unused -}])
330 tcDoStmts ListComp stmts method_names res_ty
331 = unifyListTy res_ty `thenM` \ elt_ty ->
332 tcStmts ListComp (mkListTy, elt_ty) stmts `thenM` \ stmts' ->
333 returnM (EmptyMonoBinds, stmts', [{- unused -}])
335 tcDoStmts do_or_mdo_expr stmts method_names res_ty
336 = newTyVarTy (mkArrowKind liftedTypeKind liftedTypeKind) `thenM` \ m_ty ->
337 newTyVarTy liftedTypeKind `thenM` \ elt_ty ->
338 unifyTauTy res_ty (mkAppTy m_ty elt_ty) `thenM_`
340 tcStmts do_or_mdo_expr (mkAppTy m_ty, elt_ty) stmts `thenM` \ stmts' ->
342 -- Build the then and zero methods in case we need them
343 -- It's important that "then" and "return" appear just once in the final LIE,
344 -- not only for typechecker efficiency, but also because otherwise during
345 -- simplification we end up with silly stuff like
346 -- then = case d of (t,r) -> t
348 -- where the second "then" sees that it already exists in the "available" stuff.
350 mapAndUnzipM (tc_syn_name m_ty)
351 (zipEqual "tcDoStmts" currentMonadNames method_names) `thenM` \ (binds, ids) ->
352 returnM (andMonoBindList binds, stmts', ids)
354 currentMonadNames = case do_or_mdo_expr of
356 MDoExpr -> monadNames ++ [mfixName]
357 tc_syn_name :: TcType -> (Name,Name) -> TcM (TcMonoBinds, Id)
358 tc_syn_name m_ty (std_nm, usr_nm)
359 = tcSyntaxName DoOrigin m_ty std_nm usr_nm `thenM` \ (expr, expr_ty) ->
361 HsVar v -> returnM (EmptyMonoBinds, v)
362 other -> newUnique `thenM` \ uniq ->
364 id = mkSysLocal FSLIT("syn") uniq expr_ty
366 returnM (VarMonoBind id expr, id)
370 %************************************************************************
374 %************************************************************************
376 Typechecking statements is rendered a bit tricky by parallel list comprehensions:
378 [ (g x, h x) | ... ; let g v = ...
379 | ... ; let h v = ... ]
381 It's possible that g,h are overloaded, so we need to feed the LIE from the
382 (g x, h x) up through both lots of bindings (so we get the bindInstsOfLocalFuns).
383 Similarly if we had an existential pattern match:
385 data T = forall a. Show a => C a
387 [ (show x, show y) | ... ; C x <- ...
390 Then we need the LIE from (show x, show y) to be simplified against
391 the bindings for x and y.
393 It's difficult to do this in parallel, so we rely on the renamer to
394 ensure that g,h and x,y don't duplicate, and simply grow the environment.
395 So the binders of the first parallel group will be in scope in the second
396 group. But that's fine; there's no shadowing to worry about.
399 tcStmts do_or_lc m_ty stmts
400 = ASSERT( notNull stmts )
401 tcStmtsAndThen (:) do_or_lc m_ty stmts (returnM [])
404 :: (TcStmt -> thing -> thing) -- Combiner
405 -> HsStmtContext Name
406 -> (TcType -> TcType, TcType) -- m, the relationship type of pat and rhs in pat <- rhs
407 -- elt_ty, where type of the comprehension is (m elt_ty)
413 tcStmtsAndThen combine do_or_lc m_ty [] do_next
416 tcStmtsAndThen combine do_or_lc m_ty (stmt:stmts) do_next
417 = tcStmtAndThen combine do_or_lc m_ty stmt
418 (tcStmtsAndThen combine do_or_lc m_ty stmts do_next)
421 tcStmtAndThen combine do_or_lc m_ty (LetStmt binds) thing_inside
422 = tcBindsAndThen -- No error context, but a binding group is
423 (glue_binds combine) -- rather a large thing for an error context anyway
427 tcStmtAndThen combine do_or_lc m_ty@(m,elt_ty) stmt@(BindStmt pat exp src_loc) thing_inside
428 = addSrcLoc src_loc $
429 addErrCtxt (stmtCtxt do_or_lc stmt) $
430 newTyVarTy liftedTypeKind `thenM` \ pat_ty ->
431 tcMonoExpr exp (m pat_ty) `thenM` \ exp' ->
432 tcMatchPats [pat] (mkFunTy pat_ty (m elt_ty)) (\ _ ->
433 popErrCtxt thing_inside
434 ) `thenM` \ ([pat'], thing, dict_binds) ->
435 returnM (combine (BindStmt pat' exp' src_loc)
436 (glue_binds combine dict_binds thing))
439 tcStmtAndThen combine do_or_lc m_ty (ParStmtOut bndr_stmts_s) thing_inside
440 = loop bndr_stmts_s `thenM` \ (pairs', thing) ->
441 returnM (combine (ParStmtOut pairs') thing)
444 = thing_inside `thenM` \ thing ->
447 loop ((bndrs,stmts) : pairs)
449 combine_par ListComp m_ty stmts
450 -- Notice we pass on m_ty; the result type is used only
451 -- to get escaping type variables for checkExistentialPat
452 (tcLookupLocalIds bndrs `thenM` \ bndrs' ->
453 loop pairs `thenM` \ (pairs', thing) ->
454 returnM ([], (bndrs', pairs', thing))) `thenM` \ (stmts', (bndrs', pairs', thing)) ->
456 returnM ((bndrs',stmts') : pairs', thing)
458 combine_par stmt (stmts, thing) = (stmt:stmts, thing)
461 tcStmtAndThen combine do_or_lc m_ty (RecStmt recNames stmts _) thing_inside
462 = newTyVarTys (length recNames) liftedTypeKind `thenM` \ recTys ->
464 mono_ids = zipWith mkLocalId recNames recTys
466 tcExtendLocalValEnv mono_ids $
467 tcStmtsAndThen combine_rec do_or_lc m_ty stmts (
468 mappM tc_ret (recNames `zip` recTys) `thenM` \ rets ->
470 ) `thenM` \ (stmts', rets) ->
472 -- NB: it's the mono_ids that scope over this part
473 thing_inside `thenM` \ thing ->
475 returnM (combine (RecStmt mono_ids stmts' rets) thing)
477 combine_rec stmt (stmts, thing) = (stmt:stmts, thing)
479 -- Unify the types of the "final" Ids with those of "knot-tied" Ids
480 tc_ret (rec_name, mono_ty)
481 = tcLookupId rec_name `thenM` \ poly_id ->
482 -- poly_id may have a polymorphic type
483 -- but mono_ty is just a monomorphic type variable
484 tcSubExp mono_ty (idType poly_id) `thenM` \ co_fn ->
485 returnM (co_fn <$> HsVar poly_id)
488 tcStmtAndThen combine do_or_lc m_ty@(m, res_elt_ty) stmt@(ExprStmt exp _ locn) thing_inside
489 = addErrCtxt (stmtCtxt do_or_lc stmt) (
490 if isDoExpr do_or_lc then
491 newTyVarTy openTypeKind `thenM` \ any_ty ->
492 tcMonoExpr exp (m any_ty) `thenM` \ exp' ->
493 returnM (ExprStmt exp' any_ty locn)
495 tcMonoExpr exp boolTy `thenM` \ exp' ->
496 returnM (ExprStmt exp' boolTy locn)
499 thing_inside `thenM` \ thing ->
500 returnM (combine stmt' thing)
504 tcStmtAndThen combine do_or_lc m_ty@(m, res_elt_ty) stmt@(ResultStmt exp locn) thing_inside
505 = addErrCtxt (resCtxt do_or_lc stmt) (
506 if isDoExpr do_or_lc then
507 tcMonoExpr exp (m res_elt_ty)
509 tcMonoExpr exp res_elt_ty
512 thing_inside `thenM` \ thing ->
514 returnM (combine (ResultStmt exp' locn) thing)
517 ------------------------------
518 glue_binds combine EmptyBinds thing = thing
519 glue_binds combine other_binds thing = combine (LetStmt other_binds) thing
523 %************************************************************************
525 \subsection{Errors and contexts}
527 %************************************************************************
529 @sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same
530 number of args are used in each equation.
533 sameNoOfArgs :: [RenamedMatch] -> Bool
534 sameNoOfArgs matches = isSingleton (nub (map args_in_match matches))
536 args_in_match :: RenamedMatch -> Int
537 args_in_match (Match pats _ _) = length pats
541 varyingArgsErr name matches
542 = sep [ptext SLIT("Varying number of arguments for function"), quotes (ppr name)]
544 matchCtxt ctxt match = hang (ptext SLIT("In") <+> pprMatchContext ctxt <> colon) 4 (pprMatch ctxt match)
545 stmtCtxt do_or_lc stmt = hang (ptext SLIT("In") <+> pprStmtContext do_or_lc <> colon) 4 (ppr stmt)
546 resCtxt do_or_lc stmt = hang (ptext SLIT("In") <+> pprStmtResultContext do_or_lc <> colon) 4 (ppr stmt)
548 sigPatCtxt bound_tvs bound_ids match_ty tidy_env
549 = zonkTcType match_ty `thenM` \ match_ty' ->
551 (env1, tidy_tys) = tidyOpenTypes tidy_env (map idType show_ids)
552 (env2, tidy_mty) = tidyOpenType env1 match_ty'
555 sep [ptext SLIT("When checking an existential match that binds"),
556 nest 4 (vcat (zipWith ppr_id show_ids tidy_tys)),
557 ptext SLIT("and whose type is") <+> ppr tidy_mty])
559 show_ids = filter is_interesting bound_ids
560 is_interesting id = any (`elemVarSet` idFreeTyVars id) bound_tvs
562 ppr_id id ty = ppr id <+> dcolon <+> ppr ty
563 -- Don't zonk the types so we get the separate, un-unified versions