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, tcThingWithSig
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, ExprCoFn,
25 isIdCoercion, (<$>), (<.>) )
28 import TcMonoType ( tcAddScopedTyVars, tcHsSigType, UserTypeCtxt(..) )
29 import Inst ( tcSyntaxName, tcInstCall )
30 import TcEnv ( TcId, tcLookupLocalIds, tcLookupId, tcExtendLocalValEnv, tcExtendLocalValEnv2 )
31 import TcPat ( tcPat, tcMonoPatBndr )
32 import TcMType ( newTyVarTy, newTyVarTys, zonkTcType, zapToType )
33 import TcType ( TcType, TcTyVar, TcSigmaType, TcRhoType,
34 tyVarsOfType, tidyOpenTypes, tidyOpenType, isSigmaTy,
35 mkFunTy, isOverloadedTy, liftedTypeKind, openTypeKind,
36 mkArrowKind, mkAppTy )
37 import TcBinds ( tcBindsAndThen )
38 import TcUnify ( unifyPArrTy,subFunTy, unifyListTy, unifyTauTy,
39 checkSigTyVarsWrt, tcSubExp, tcGen )
40 import TcSimplify ( tcSimplifyCheck, bindInstsOfLocalFuns )
42 import PrelNames ( monadNames, mfixName )
43 import TysWiredIn ( boolTy, mkListTy, mkPArrTy )
44 import Id ( idType, mkSysLocal, mkLocalId )
45 import CoreFVs ( idFreeTyVars )
46 import BasicTypes ( RecFlag(..) )
50 import Util ( isSingleton, lengthExceeds, notNull, zipEqual )
56 %************************************************************************
58 \subsection{tcMatchesFun, tcMatchesCase}
60 %************************************************************************
62 @tcMatchesFun@ typechecks a @[Match]@ list which occurs in a
63 @FunMonoBind@. The second argument is the name of the function, which
64 is used in error messages. It checks that all the equations have the
65 same number of arguments before using @tcMatches@ to do the work.
69 -> TcType -- Expected type
73 tcMatchesFun fun_name expected_ty matches@(first_match:_)
74 = -- Check that they all have the same no of arguments
75 -- Set the location to that of the first equation, so that
76 -- any inter-equation error messages get some vaguely
77 -- sensible location. Note: we have to do this odd
78 -- ann-grabbing, because we don't always have annotations in
79 -- hand when we call tcMatchesFun...
80 addSrcLoc (getMatchLoc first_match) (
81 checkTc (sameNoOfArgs matches)
82 (varyingArgsErr fun_name matches)
85 -- ToDo: Don't use "expected" stuff if there ain't a type signature
86 -- because inconsistency between branches
87 -- may show up as something wrong with the (non-existent) type signature
89 -- No need to zonk expected_ty, because subFunTy does that on the fly
90 tcMatches (FunRhs fun_name) matches expected_ty
93 @tcMatchesCase@ doesn't do the argument-count check because the
94 parser guarantees that each equation has exactly one argument.
97 tcMatchesCase :: [RenamedMatch] -- The case alternatives
98 -> TcType -- Type of whole case expressions
99 -> TcM (TcType, -- Inferred type of the scrutinee
100 [TcMatch]) -- Translated alternatives
102 tcMatchesCase matches expr_ty
103 = newTyVarTy openTypeKind `thenM` \ scrut_ty ->
104 tcMatches CaseAlt matches (mkFunTy scrut_ty expr_ty) `thenM` \ matches' ->
105 returnM (scrut_ty, matches')
107 tcMatchLambda :: RenamedMatch -> TcType -> TcM TcMatch
108 tcMatchLambda match res_ty = tcMatch LambdaExpr match res_ty
113 tcMatches :: RenamedMatchContext
118 tcMatches 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 ctxt match expected_ty
133 %************************************************************************
137 %************************************************************************
140 tcMatch :: RenamedMatchContext
142 -> TcType -- Expected result-type of the Match.
143 -- Early unification with this guy gives better error messages
144 -- We regard the Match as having type
145 -- (ty1 -> ... -> tyn -> result_ty)
146 -- where there are n patterns.
149 tcMatch ctxt match@(Match pats maybe_rhs_sig grhss) expected_ty
150 = addSrcLoc (getMatchLoc match) $ -- At one stage I removed this;
151 addErrCtxt (matchCtxt ctxt match) $ -- I'm not sure why, so I put it back
152 tcMatchPats pats expected_ty tc_grhss `thenM` \ (pats', grhss', ex_binds) ->
153 returnM (Match pats' Nothing (glue_on ex_binds grhss'))
157 = -- Deal with the result signature
158 case maybe_rhs_sig of
159 Nothing -> tcGRHSs ctxt grhss rhs_ty
161 Just sig -> tcAddScopedTyVars [sig] $
162 -- Bring into scope the type variables in the signature
163 tcHsSigType ResSigCtxt sig `thenM` \ sig_ty ->
164 tcThingWithSig sig_ty (tcGRHSs ctxt grhss) rhs_ty `thenM` \ (co_fn, grhss') ->
165 returnM (lift_grhss co_fn rhs_ty grhss')
167 -- lift_grhss pushes the coercion down to the right hand sides,
168 -- because there is no convenient place to hang it otherwise.
169 lift_grhss co_fn rhs_ty grhss
170 | isIdCoercion co_fn = grhss
171 lift_grhss co_fn rhs_ty (GRHSs grhss binds ty)
172 = GRHSs (map lift_grhs grhss) binds rhs_ty -- Change the type, since the coercion does
174 lift_grhs (GRHS stmts loc) = GRHS (map lift_stmt stmts) loc
176 lift_stmt (ResultStmt e l) = ResultStmt (co_fn <$> e) l
177 lift_stmt stmt = stmt
179 -- glue_on just avoids stupid dross
180 glue_on EmptyBinds grhss = grhss -- The common case
181 glue_on binds1 (GRHSs grhss binds2 ty)
182 = GRHSs grhss (binds1 `ThenBinds` binds2) ty
185 tcGRHSs :: RenamedMatchContext -> RenamedGRHSs
189 tcGRHSs ctxt (GRHSs grhss binds _) expected_ty
190 = tcBindsAndThen glue_on binds (tc_grhss grhss)
192 m_ty = (\ty -> ty, expected_ty)
195 = mappM tc_grhs grhss `thenM` \ grhss' ->
196 returnM (GRHSs grhss' EmptyBinds expected_ty)
198 tc_grhs (GRHS guarded locn)
200 tcStmts (PatGuard ctxt) m_ty guarded `thenM` \ guarded' ->
201 returnM (GRHS guarded' locn)
206 tcThingWithSig :: TcSigmaType -- Type signature
207 -> (TcRhoType -> TcM r) -- How to type check the thing inside
208 -> TcRhoType -- Overall expected result type
210 -- Used for expressions with a type signature, and for result type signatures
212 tcThingWithSig sig_ty thing_inside res_ty
213 | not (isSigmaTy sig_ty)
214 = thing_inside sig_ty `thenM` \ result ->
215 tcSubExp res_ty sig_ty `thenM` \ co_fn ->
216 returnM (co_fn, result)
218 | otherwise -- The signature has some outer foralls
219 = -- Must instantiate the outer for-alls of sig_tc_ty
220 -- else we risk instantiating a ? res_ty to a forall-type
221 -- which breaks the invariant that tcMonoExpr only returns phi-types
222 tcGen sig_ty emptyVarSet thing_inside `thenM` \ (gen_fn, result) ->
223 tcInstCall SignatureOrigin sig_ty `thenM` \ (inst_fn, inst_sig_ty) ->
224 tcSubExp res_ty inst_sig_ty `thenM` \ co_fn ->
225 returnM (co_fn <.> inst_fn <.> gen_fn, result)
226 -- Note that we generalise, then instantiate. Ah well.
230 %************************************************************************
232 \subsection{tcMatchPats}
234 %************************************************************************
238 :: [RenamedPat] -> TcType
240 -> TcM ([TcPat], a, TcHsBinds)
241 -- Typecheck the patterns, extend the environment to bind the variables,
242 -- do the thing inside, use any existentially-bound dictionaries to
243 -- discharge parts of the returning LIE, and deal with pattern type
246 tcMatchPats pats expected_ty thing_inside
247 = -- STEP 1: Bring pattern-signature type variables into scope
248 tcAddScopedTyVars (collectSigTysFromPats pats) (
250 -- STEP 2: Typecheck the patterns themselves, gathering all the stuff
251 -- then do the thing inside
252 getLIE (tc_match_pats pats expected_ty thing_inside)
254 ) `thenM` \ ((pats', ex_tvs, ex_ids, ex_lie, result), lie_req) ->
256 -- STEP 4: Check for existentially bound type variables
257 -- Do this *outside* the scope of the tcAddScopedTyVars, else checkSigTyVars
258 -- complains that 'a' is captured by the inscope 'a'! (Test (d) in checkSigTyVars.)
260 -- I'm a bit concerned that lie_req1 from an 'inner' pattern in the list
261 -- might need (via lie_req2) something made available from an 'outer'
262 -- pattern. But it's inconvenient to deal with, and I can't find an example
263 tcCheckExistentialPat ex_tvs ex_ids ex_lie lie_req expected_ty `thenM` \ ex_binds ->
264 -- NB: we *must* pass "expected_ty" not "result_ty" to tcCheckExistentialPat
265 -- For example, we must reject this program:
266 -- data C = forall a. C (a -> Int)
268 -- Here, result_ty will be simply Int, but expected_ty is (a -> Int).
270 returnM (pats', result, mkMonoBind Recursive ex_binds)
272 tc_match_pats [] expected_ty thing_inside
273 = thing_inside expected_ty `thenM` \ answer ->
274 returnM ([], emptyBag, [], [], answer)
276 tc_match_pats (pat:pats) expected_ty thing_inside
277 = subFunTy expected_ty $ \ arg_ty rest_ty ->
278 -- This is the unique place we call subFunTy
279 -- The point is that if expected_y is a "hole", we want
280 -- to make arg_ty and rest_ty as "holes" too.
281 tcPat tcMonoPatBndr pat arg_ty `thenM` \ (pat', ex_tvs, pat_bndrs, ex_lie) ->
283 xve = bagToList pat_bndrs
284 ex_ids = [id | (_, id) <- xve]
285 -- ex_ids is all the pattern-bound Ids, a superset
286 -- of the existential Ids used in checkExistentialPat
288 tcExtendLocalValEnv2 xve $
289 tc_match_pats pats rest_ty thing_inside `thenM` \ (pats', exs_tvs, exs_ids, exs_lie, answer) ->
290 returnM ( pat':pats',
291 ex_tvs `unionBags` exs_tvs,
298 tcCheckExistentialPat :: Bag TcTyVar -- Existentially quantified tyvars bound by pattern
299 -> [TcId] -- Ids bound by this pattern; used
300 -- (a) by bindsInstsOfLocalFuns
301 -- (b) to generate helpful error messages
302 -> [Inst] -- and context
303 -> [Inst] -- Required context
304 -> TcType -- and type of the Match; vars in here must not escape
305 -> TcM TcDictBinds -- LIE to float out and dict bindings
306 tcCheckExistentialPat ex_tvs ex_ids ex_lie lie_req match_ty
307 | isEmptyBag ex_tvs && all not_overloaded ex_ids
308 -- Short cut for case when there are no existentials
309 -- and no polymorphic overloaded variables
310 -- e.g. f :: (forall a. Ord a => a -> a) -> Int -> Int
312 -- Here we must discharge op Methods
313 = ASSERT( null ex_lie )
314 extendLIEs lie_req `thenM_`
315 returnM EmptyMonoBinds
318 = addErrCtxtM (sigPatCtxt tv_list ex_ids match_ty) $
320 -- In case there are any polymorpic, overloaded binders in the pattern
321 -- (which can happen in the case of rank-2 type signatures, or data constructors
322 -- with polymorphic arguments), we must do a bindInstsOfLocalFns here
323 getLIE (bindInstsOfLocalFuns lie_req ex_ids) `thenM` \ (inst_binds, lie) ->
325 -- Deal with overloaded functions bound by the pattern
326 tcSimplifyCheck doc tv_list ex_lie lie `thenM` \ dict_binds ->
327 checkSigTyVarsWrt (tyVarsOfType match_ty) tv_list `thenM_`
329 returnM (dict_binds `AndMonoBinds` inst_binds)
331 doc = text ("existential context of a data constructor")
332 tv_list = bagToList ex_tvs
333 not_overloaded id = not (isOverloadedTy (idType id))
337 %************************************************************************
339 \subsection{@tcDoStmts@ typechecks a {\em list} of do statements}
341 %************************************************************************
344 tcDoStmts :: HsStmtContext Name -> [RenamedStmt] -> [Name] -> TcType
345 -> TcM (TcMonoBinds, [TcStmt], [Id])
346 tcDoStmts PArrComp stmts method_names res_ty
347 = unifyPArrTy res_ty `thenM` \elt_ty ->
348 tcStmts PArrComp (mkPArrTy, elt_ty) stmts `thenM` \ stmts' ->
349 returnM (EmptyMonoBinds, stmts', [{- unused -}])
351 tcDoStmts ListComp stmts method_names res_ty
352 = unifyListTy res_ty `thenM` \ elt_ty ->
353 tcStmts ListComp (mkListTy, elt_ty) stmts `thenM` \ stmts' ->
354 returnM (EmptyMonoBinds, stmts', [{- unused -}])
356 tcDoStmts do_or_mdo_expr stmts method_names res_ty
357 = newTyVarTy (mkArrowKind liftedTypeKind liftedTypeKind) `thenM` \ m_ty ->
358 newTyVarTy liftedTypeKind `thenM` \ elt_ty ->
359 unifyTauTy res_ty (mkAppTy m_ty elt_ty) `thenM_`
361 tcStmts do_or_mdo_expr (mkAppTy m_ty, elt_ty) stmts `thenM` \ stmts' ->
363 -- Build the then and zero methods in case we need them
364 -- It's important that "then" and "return" appear just once in the final LIE,
365 -- not only for typechecker efficiency, but also because otherwise during
366 -- simplification we end up with silly stuff like
367 -- then = case d of (t,r) -> t
369 -- where the second "then" sees that it already exists in the "available" stuff.
371 mapAndUnzipM (tc_syn_name m_ty)
372 (zipEqual "tcDoStmts" currentMonadNames method_names) `thenM` \ (binds, ids) ->
373 returnM (andMonoBindList binds, stmts', ids)
375 currentMonadNames = case do_or_mdo_expr of
377 MDoExpr -> monadNames ++ [mfixName]
378 tc_syn_name :: TcType -> (Name,Name) -> TcM (TcMonoBinds, Id)
379 tc_syn_name m_ty (std_nm, usr_nm)
380 = tcSyntaxName DoOrigin m_ty std_nm usr_nm `thenM` \ (expr, expr_ty) ->
382 HsVar v -> returnM (EmptyMonoBinds, v)
383 other -> newUnique `thenM` \ uniq ->
385 id = mkSysLocal FSLIT("syn") uniq expr_ty
387 returnM (VarMonoBind id expr, id)
391 %************************************************************************
395 %************************************************************************
397 Typechecking statements is rendered a bit tricky by parallel list comprehensions:
399 [ (g x, h x) | ... ; let g v = ...
400 | ... ; let h v = ... ]
402 It's possible that g,h are overloaded, so we need to feed the LIE from the
403 (g x, h x) up through both lots of bindings (so we get the bindInstsOfLocalFuns).
404 Similarly if we had an existential pattern match:
406 data T = forall a. Show a => C a
408 [ (show x, show y) | ... ; C x <- ...
411 Then we need the LIE from (show x, show y) to be simplified against
412 the bindings for x and y.
414 It's difficult to do this in parallel, so we rely on the renamer to
415 ensure that g,h and x,y don't duplicate, and simply grow the environment.
416 So the binders of the first parallel group will be in scope in the second
417 group. But that's fine; there's no shadowing to worry about.
420 tcStmts do_or_lc m_ty stmts
421 = ASSERT( notNull stmts )
422 tcStmtsAndThen (:) do_or_lc m_ty stmts (returnM [])
425 :: (TcStmt -> thing -> thing) -- Combiner
426 -> HsStmtContext Name
427 -> (TcType -> TcType, TcType) -- m, the relationship type of pat and rhs in pat <- rhs
428 -- elt_ty, where type of the comprehension is (m elt_ty)
434 tcStmtsAndThen combine do_or_lc m_ty [] do_next
437 tcStmtsAndThen combine do_or_lc m_ty (stmt:stmts) do_next
438 = tcStmtAndThen combine do_or_lc m_ty stmt
439 (tcStmtsAndThen combine do_or_lc m_ty stmts do_next)
442 tcStmtAndThen combine do_or_lc m_ty (LetStmt binds) thing_inside
443 = tcBindsAndThen -- No error context, but a binding group is
444 (glue_binds combine) -- rather a large thing for an error context anyway
448 tcStmtAndThen combine do_or_lc m_ty@(m,elt_ty) stmt@(BindStmt pat exp src_loc) thing_inside
449 = addSrcLoc src_loc $
450 addErrCtxt (stmtCtxt do_or_lc stmt) $
451 newTyVarTy liftedTypeKind `thenM` \ pat_ty ->
452 tcMonoExpr exp (m pat_ty) `thenM` \ exp' ->
453 tcMatchPats [pat] (mkFunTy pat_ty (m elt_ty)) (\ _ ->
454 popErrCtxt thing_inside
455 ) `thenM` \ ([pat'], thing, dict_binds) ->
456 returnM (combine (BindStmt pat' exp' src_loc)
457 (glue_binds combine dict_binds thing))
460 tcStmtAndThen combine do_or_lc m_ty (ParStmtOut bndr_stmts_s) thing_inside
461 = loop bndr_stmts_s `thenM` \ (pairs', thing) ->
462 returnM (combine (ParStmtOut pairs') thing)
465 = thing_inside `thenM` \ thing ->
468 loop ((bndrs,stmts) : pairs)
470 combine_par ListComp m_ty stmts
471 -- Notice we pass on m_ty; the result type is used only
472 -- to get escaping type variables for checkExistentialPat
473 (tcLookupLocalIds bndrs `thenM` \ bndrs' ->
474 loop pairs `thenM` \ (pairs', thing) ->
475 returnM ([], (bndrs', pairs', thing))) `thenM` \ (stmts', (bndrs', pairs', thing)) ->
477 returnM ((bndrs',stmts') : pairs', thing)
479 combine_par stmt (stmts, thing) = (stmt:stmts, thing)
482 tcStmtAndThen combine do_or_lc m_ty (RecStmt recNames stmts _) thing_inside
483 = newTyVarTys (length recNames) liftedTypeKind `thenM` \ recTys ->
485 mono_ids = zipWith mkLocalId recNames recTys
487 tcExtendLocalValEnv mono_ids $
488 tcStmtsAndThen combine_rec do_or_lc m_ty stmts (
489 mappM tc_ret (recNames `zip` recTys) `thenM` \ rets ->
491 ) `thenM` \ (stmts', rets) ->
493 -- NB: it's the mono_ids that scope over this part
494 thing_inside `thenM` \ thing ->
496 returnM (combine (RecStmt mono_ids stmts' rets) thing)
498 combine_rec stmt (stmts, thing) = (stmt:stmts, thing)
500 -- Unify the types of the "final" Ids with those of "knot-tied" Ids
501 tc_ret (rec_name, mono_ty)
502 = tcLookupId rec_name `thenM` \ poly_id ->
503 -- poly_id may have a polymorphic type
504 -- but mono_ty is just a monomorphic type variable
505 tcSubExp mono_ty (idType poly_id) `thenM` \ co_fn ->
506 returnM (co_fn <$> HsVar poly_id)
509 tcStmtAndThen combine do_or_lc m_ty@(m, res_elt_ty) stmt@(ExprStmt exp _ locn) thing_inside
510 = addErrCtxt (stmtCtxt do_or_lc stmt) (
511 if isDoExpr do_or_lc then
512 newTyVarTy openTypeKind `thenM` \ any_ty ->
513 tcMonoExpr exp (m any_ty) `thenM` \ exp' ->
514 returnM (ExprStmt exp' any_ty locn)
516 tcMonoExpr exp boolTy `thenM` \ exp' ->
517 returnM (ExprStmt exp' boolTy locn)
520 thing_inside `thenM` \ thing ->
521 returnM (combine stmt' thing)
525 tcStmtAndThen combine do_or_lc m_ty@(m, res_elt_ty) stmt@(ResultStmt exp locn) thing_inside
526 = addErrCtxt (resCtxt do_or_lc stmt) (
527 if isDoExpr do_or_lc then
528 tcMonoExpr exp (m res_elt_ty)
530 tcMonoExpr exp res_elt_ty
533 thing_inside `thenM` \ thing ->
535 returnM (combine (ResultStmt exp' locn) thing)
538 ------------------------------
539 glue_binds combine EmptyBinds thing = thing
540 glue_binds combine other_binds thing = combine (LetStmt other_binds) thing
544 %************************************************************************
546 \subsection{Errors and contexts}
548 %************************************************************************
550 @sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same
551 number of args are used in each equation.
554 sameNoOfArgs :: [RenamedMatch] -> Bool
555 sameNoOfArgs matches = isSingleton (nub (map args_in_match matches))
557 args_in_match :: RenamedMatch -> Int
558 args_in_match (Match pats _ _) = length pats
562 varyingArgsErr name matches
563 = sep [ptext SLIT("Varying number of arguments for function"), quotes (ppr name)]
565 matchCtxt ctxt match = hang (ptext SLIT("In") <+> pprMatchContext ctxt <> colon) 4 (pprMatch ctxt match)
566 stmtCtxt do_or_lc stmt = hang (ptext SLIT("In") <+> pprStmtContext do_or_lc <> colon) 4 (ppr stmt)
567 resCtxt do_or_lc stmt = hang (ptext SLIT("In") <+> pprStmtResultContext do_or_lc <> colon) 4 (ppr stmt)
569 sigPatCtxt bound_tvs bound_ids match_ty tidy_env
570 = zonkTcType match_ty `thenM` \ match_ty' ->
572 (env1, tidy_tys) = tidyOpenTypes tidy_env (map idType show_ids)
573 (env2, tidy_mty) = tidyOpenType env1 match_ty'
576 sep [ptext SLIT("When checking an existential match that binds"),
577 nest 4 (vcat (zipWith ppr_id show_ids tidy_tys)),
578 ptext SLIT("and whose type is") <+> ppr tidy_mty])
580 show_ids = filter is_interesting bound_ids
581 is_interesting id = any (`elemVarSet` idFreeTyVars id) bound_tvs
583 ppr_id id ty = ppr id <+> dcolon <+> ppr ty
584 -- Don't zonk the types so we get the separate, un-unified versions