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, nullMonoBinds, collectSigTysFromPats, andMonoBindList
21 import RnHsSyn ( RenamedMatch, RenamedGRHSs, RenamedStmt,
22 RenamedPat, RenamedMatchContext )
23 import TcHsSyn ( TcMatch, TcGRHSs, TcStmt, TcDictBinds,
24 TcMonoBinds, TcPat, TcStmt )
27 import TcMonoType ( tcAddScopedTyVars, tcHsSigType, UserTypeCtxt(..) )
28 import Inst ( tcSyntaxName )
29 import TcEnv ( TcId, tcLookupLocalIds, 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, (<$>), unifyTauTyLists )
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 Recursive 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 _ EmptyMonoBinds grhss = grhss -- The common case
185 glue_on is_rec mbinds (GRHSs grhss binds ty)
186 = GRHSs grhss (mkMonoBind mbinds [] is_rec `ThenBinds` binds) 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, TcDictBinds)
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, 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 Recursive 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 ->
463 tcExtendLocalValEnv (zipWith mkLocalId recNames recTys) $
464 tcStmtsAndThen combine_rec do_or_lc m_ty stmts (
465 tcLookupLocalIds recNames `thenM` \ rn ->
467 ) `thenM` \ (stmts', recIds) ->
469 -- Unify the types of the "final" Ids with those of "knot-tied" Ids
470 mappM tc_ret (recIds `zip` recTys) `thenM` \ rets' ->
472 thing_inside `thenM` \ thing ->
474 returnM (combine (RecStmt recIds stmts' rets') thing)
476 combine_rec stmt (stmts, thing) = (stmt:stmts, thing)
478 -- Unify the types of the "final" Ids with those of "knot-tied" Ids
479 tc_ret (rec_id, rec_ty)
480 = tcSubExp rec_ty (idType rec_id) `thenM` \ co_fn ->
481 returnM (co_fn <$> HsVar rec_id)
484 tcStmtAndThen combine do_or_lc m_ty@(m, res_elt_ty) stmt@(ExprStmt exp _ locn) thing_inside
485 = addErrCtxt (stmtCtxt do_or_lc stmt) (
486 if isDoExpr do_or_lc then
487 newTyVarTy openTypeKind `thenM` \ any_ty ->
488 tcMonoExpr exp (m any_ty) `thenM` \ exp' ->
489 returnM (ExprStmt exp' any_ty locn)
491 tcMonoExpr exp boolTy `thenM` \ exp' ->
492 returnM (ExprStmt exp' boolTy locn)
495 thing_inside `thenM` \ thing ->
496 returnM (combine stmt' thing)
500 tcStmtAndThen combine do_or_lc m_ty@(m, res_elt_ty) stmt@(ResultStmt exp locn) thing_inside
501 = addErrCtxt (resCtxt do_or_lc stmt) (
502 if isDoExpr do_or_lc then
503 tcMonoExpr exp (m res_elt_ty)
505 tcMonoExpr exp res_elt_ty
508 thing_inside `thenM` \ thing ->
510 returnM (combine (ResultStmt exp' locn) thing)
513 ------------------------------
514 glue_binds combine is_rec binds thing
515 | nullMonoBinds binds = thing
516 | otherwise = combine (LetStmt (mkMonoBind binds [] is_rec)) thing
520 %************************************************************************
522 \subsection{Errors and contexts}
524 %************************************************************************
526 @sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same
527 number of args are used in each equation.
530 sameNoOfArgs :: [RenamedMatch] -> Bool
531 sameNoOfArgs matches = isSingleton (nub (map args_in_match matches))
533 args_in_match :: RenamedMatch -> Int
534 args_in_match (Match pats _ _) = length pats
538 varyingArgsErr name matches
539 = sep [ptext SLIT("Varying number of arguments for function"), quotes (ppr name)]
541 matchCtxt ctxt match = hang (ptext SLIT("In") <+> pprMatchContext ctxt <> colon) 4 (pprMatch ctxt match)
542 stmtCtxt do_or_lc stmt = hang (ptext SLIT("In") <+> pprStmtContext do_or_lc <> colon) 4 (ppr stmt)
543 resCtxt do_or_lc stmt = hang (ptext SLIT("In") <+> pprStmtResultContext do_or_lc <> colon) 4 (ppr stmt)
545 sigPatCtxt bound_tvs bound_ids match_ty tidy_env
546 = zonkTcType match_ty `thenM` \ match_ty' ->
548 (env1, tidy_tys) = tidyOpenTypes tidy_env (map idType show_ids)
549 (env2, tidy_mty) = tidyOpenType env1 match_ty'
552 sep [ptext SLIT("When checking an existential match that binds"),
553 nest 4 (vcat (zipWith ppr_id show_ids tidy_tys)),
554 ptext SLIT("and whose type is") <+> ppr tidy_mty])
556 show_ids = filter is_interesting bound_ids
557 is_interesting id = any (`elemVarSet` idFreeTyVars id) bound_tvs
559 ppr_id id ty = ppr id <+> dcolon <+> ppr ty
560 -- Don't zonk the types so we get the separate, un-unified versions