2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[TcMatches]{Typecheck some @Matches@}
7 module TcMatches ( tcMatchesFun, tcMatchesCase, tcMatchLambda,
8 tcStmts, tcStmtsAndThen, tcGRHSs
11 #include "HsVersions.h"
13 import {-# SOURCE #-} TcExpr( tcMonoExpr )
15 import HsSyn ( HsBinds(..), Match(..), GRHSs(..), GRHS(..),
16 MonoBinds(..), Stmt(..), HsMatchContext(..), HsDoContext(..),
17 pprMatch, getMatchLoc, pprMatchContext, isDoExpr,
18 mkMonoBind, nullMonoBinds, collectSigTysFromPats
20 import RnHsSyn ( RenamedMatch, RenamedGRHSs, RenamedStmt, RenamedPat, RenamedMatchContext )
21 import TcHsSyn ( TcMatch, TcGRHSs, TcStmt, TcDictBinds, TypecheckedPat )
24 import TcMonoType ( tcAddScopedTyVars, tcHsSigType, UserTypeCtxt(..) )
25 import Inst ( LIE, isEmptyLIE, plusLIE, emptyLIE, plusLIEs, lieToList )
26 import TcEnv ( TcId, tcLookupLocalIds, tcExtendLocalValEnv2 )
27 import TcPat ( tcPat, tcMonoPatBndr )
28 import TcMType ( newTyVarTy, zonkTcType, zapToType )
29 import TcType ( TcType, TcTyVar, tyVarsOfType, tidyOpenTypes, tidyOpenType,
30 mkFunTy, isOverloadedTy, liftedTypeKind, openTypeKind )
31 import TcBinds ( tcBindsAndThen )
32 import TcUnify ( subFunTy, checkSigTyVarsWrt, tcSubExp, isIdCoercion, (<$>) )
33 import TcSimplify ( tcSimplifyCheck, bindInstsOfLocalFuns )
35 import TysWiredIn ( boolTy )
37 import CoreFVs ( idFreeTyVars )
38 import BasicTypes ( RecFlag(..) )
42 import Util ( isSingleton, lengthExceeds, notNull )
48 %************************************************************************
50 \subsection{tcMatchesFun, tcMatchesCase}
52 %************************************************************************
54 @tcMatchesFun@ typechecks a @[Match]@ list which occurs in a
55 @FunMonoBind@. The second argument is the name of the function, which
56 is used in error messages. It checks that all the equations have the
57 same number of arguments before using @tcMatches@ to do the work.
60 tcMatchesFun :: [(Name,Id)] -- Bindings for the variables bound in this group
62 -> TcType -- Expected type
64 -> TcM ([TcMatch], LIE)
66 tcMatchesFun xve fun_name expected_ty matches@(first_match:_)
67 = -- Check that they all have the same no of arguments
68 -- Set the location to that of the first equation, so that
69 -- any inter-equation error messages get some vaguely
70 -- sensible location. Note: we have to do this odd
71 -- ann-grabbing, because we don't always have annotations in
72 -- hand when we call tcMatchesFun...
73 tcAddSrcLoc (getMatchLoc first_match) (
74 checkTc (sameNoOfArgs matches)
75 (varyingArgsErr fun_name matches)
78 -- ToDo: Don't use "expected" stuff if there ain't a type signature
79 -- because inconsistency between branches
80 -- may show up as something wrong with the (non-existent) type signature
82 -- No need to zonk expected_ty, because subFunTy does that on the fly
83 tcMatches xve (FunRhs fun_name) matches expected_ty
86 @tcMatchesCase@ doesn't do the argument-count check because the
87 parser guarantees that each equation has exactly one argument.
90 tcMatchesCase :: [RenamedMatch] -- The case alternatives
91 -> TcType -- Type of whole case expressions
92 -> TcM (TcType, -- Inferred type of the scrutinee
93 [TcMatch], -- Translated alternatives
96 tcMatchesCase matches expr_ty
97 = newTyVarTy openTypeKind `thenNF_Tc` \ scrut_ty ->
98 tcMatches [] CaseAlt matches (mkFunTy scrut_ty expr_ty) `thenTc` \ (matches', lie) ->
99 returnTc (scrut_ty, matches', lie)
101 tcMatchLambda :: RenamedMatch -> TcType -> TcM (TcMatch, LIE)
102 tcMatchLambda match res_ty = tcMatch [] LambdaExpr match res_ty
107 tcMatches :: [(Name,Id)]
108 -> RenamedMatchContext
111 -> TcM ([TcMatch], LIE)
113 tcMatches xve ctxt matches expected_ty
114 = -- If there is more than one branch, and expected_ty is a 'hole',
115 -- all branches must be types, not type schemes, otherwise the
116 -- in which we check them would affect the result.
117 (if lengthExceeds matches 1 then
118 zapToType expected_ty
120 returnNF_Tc expected_ty) `thenNF_Tc` \ expected_ty' ->
122 mapAndUnzipTc (tc_match expected_ty') matches `thenTc` \ (matches, lies) ->
123 returnTc (matches, plusLIEs lies)
125 tc_match expected_ty match = tcMatch xve ctxt match expected_ty
129 %************************************************************************
133 %************************************************************************
136 tcMatch :: [(Name,Id)]
137 -> RenamedMatchContext
139 -> TcType -- Expected result-type of the Match.
140 -- Early unification with this guy gives better error messages
141 -- We regard the Match as having type
142 -- (ty1 -> ... -> tyn -> result_ty)
143 -- where there are n patterns.
144 -> TcM (TcMatch, LIE)
146 tcMatch xve1 ctxt match@(Match pats maybe_rhs_sig grhss) expected_ty
147 = tcAddSrcLoc (getMatchLoc match) $ -- At one stage I removed this;
148 tcAddErrCtxt (matchCtxt ctxt match) $ -- I'm not sure why, so I put it back
149 tcMatchPats pats expected_ty tc_grhss `thenTc` \ (pats', grhss', lie, ex_binds) ->
150 returnTc (Match pats' Nothing (glue_on Recursive ex_binds grhss'), lie)
154 = tcExtendLocalValEnv2 xve1 $
156 -- Deal with the result signature
157 case maybe_rhs_sig of
158 Nothing -> tcGRHSs ctxt grhss rhs_ty
160 Just sig -> tcAddScopedTyVars [sig] $
161 -- Bring into scope the type variables in the signature
162 tcHsSigType ResSigCtxt sig `thenTc` \ sig_ty ->
163 tcGRHSs ctxt grhss sig_ty `thenTc` \ (grhss', lie1) ->
164 tcSubExp rhs_ty sig_ty `thenTc` \ (co_fn, lie2) ->
165 returnTc (lift_grhss co_fn rhs_ty grhss',
168 -- lift_grhss pushes the coercion down to the right hand sides,
169 -- because there is no convenient place to hang it otherwise.
170 lift_grhss co_fn rhs_ty grhss
171 | isIdCoercion co_fn = grhss
172 lift_grhss co_fn rhs_ty (GRHSs grhss binds ty)
173 = GRHSs (map lift_grhs grhss) binds rhs_ty -- Change the type, since we
175 lift_grhs (GRHS stmts loc) = GRHS (map lift_stmt stmts) loc
177 lift_stmt (ResultStmt e l) = ResultStmt (co_fn <$> e) l
178 lift_stmt stmt = stmt
180 -- glue_on just avoids stupid dross
181 glue_on _ EmptyMonoBinds grhss = grhss -- The common case
182 glue_on is_rec mbinds (GRHSs grhss binds ty)
183 = GRHSs grhss (mkMonoBind mbinds [] is_rec `ThenBinds` binds) ty
186 tcGRHSs :: RenamedMatchContext -> RenamedGRHSs
188 -> TcM (TcGRHSs, LIE)
190 tcGRHSs ctxt (GRHSs grhss binds _) expected_ty
191 = tcBindsAndThen glue_on binds (tc_grhss grhss)
194 = mapAndUnzipTc tc_grhs grhss `thenTc` \ (grhss', lies) ->
195 returnTc (GRHSs grhss' EmptyBinds expected_ty, plusLIEs lies)
197 tc_grhs (GRHS guarded locn)
199 tcStmts ctxt (\ty -> ty, expected_ty) guarded `thenTc` \ (guarded', lie) ->
200 returnTc (GRHS guarded' locn, lie)
204 %************************************************************************
206 \subsection{tcMatchPats}
208 %************************************************************************
212 :: [RenamedPat] -> TcType
213 -> (TcType -> TcM (a, LIE))
214 -> TcM ([TypecheckedPat], a, LIE, TcDictBinds)
215 -- Typecheck the patterns, extend the environment to bind the variables,
216 -- do the thing inside, use any existentially-bound dictionaries to
217 -- discharge parts of the returning LIE, and deal with pattern type
220 tcMatchPats pats expected_ty thing_inside
221 = -- STEP 1: Bring pattern-signature type variables into scope
222 tcAddScopedTyVars (collectSigTysFromPats pats) (
224 -- STEP 2: Typecheck the patterns themselves, gathering all the stuff
225 -- then do the thing inside
226 tc_match_pats pats expected_ty thing_inside
228 ) `thenTc` \ (pats', lie_req, ex_tvs, ex_ids, ex_lie, result) ->
230 -- STEP 4: Check for existentially bound type variables
231 -- Do this *outside* the scope of the tcAddScopedTyVars, else checkSigTyVars
232 -- complains that 'a' is captured by the inscope 'a'! (Test (d) in checkSigTyVars.)
234 -- I'm a bit concerned that lie_req1 from an 'inner' pattern in the list
235 -- might need (via lie_req2) something made available from an 'outer'
236 -- pattern. But it's inconvenient to deal with, and I can't find an example
237 tcCheckExistentialPat ex_tvs ex_ids ex_lie lie_req expected_ty `thenTc` \ (lie_req', ex_binds) ->
238 -- NB: we *must* pass "expected_ty" not "result_ty" to tcCheckExistentialPat
239 -- For example, we must reject this program:
240 -- data C = forall a. C (a -> Int)
242 -- Here, result_ty will be simply Int, but expected_ty is (a -> Int).
244 returnTc (pats', result, lie_req', ex_binds)
246 tc_match_pats [] expected_ty thing_inside
247 = thing_inside expected_ty `thenTc` \ (answer, lie) ->
248 returnTc ([], lie, emptyBag, [], emptyLIE, answer)
250 tc_match_pats (pat:pats) expected_ty thing_inside
251 = subFunTy expected_ty $ \ arg_ty rest_ty ->
252 -- This is the unique place we call subFunTy
253 -- The point is that if expected_y is a "hole", we want
254 -- to make arg_ty and rest_ty as "holes" too.
255 tcPat tcMonoPatBndr pat arg_ty `thenTc` \ (pat', lie_req, ex_tvs, pat_bndrs, ex_lie) ->
257 xve = bagToList pat_bndrs
258 ex_ids = [id | (_, id) <- xve]
259 -- ex_ids is all the pattern-bound Ids, a superset
260 -- of the existential Ids used in checkExistentialPat
262 tcExtendLocalValEnv2 xve $
263 tc_match_pats pats rest_ty thing_inside `thenTc` \ (pats', lie_reqs, exs_tvs, exs_ids, exs_lie, answer) ->
264 returnTc ( pat':pats',
265 lie_req `plusLIE` lie_reqs,
266 ex_tvs `unionBags` exs_tvs,
268 ex_lie `plusLIE` exs_lie,
273 tcCheckExistentialPat :: Bag TcTyVar -- Existentially quantified tyvars bound by pattern
274 -> [TcId] -- Ids bound by this pattern; used
275 -- (a) by bindsInstsOfLocalFuns
276 -- (b) to generate helpful error messages
277 -> LIE -- and context
278 -> LIE -- Required context
279 -> TcType -- and type of the Match; vars in here must not escape
280 -> TcM (LIE, TcDictBinds) -- LIE to float out and dict bindings
281 tcCheckExistentialPat ex_tvs ex_ids ex_lie lie_req match_ty
282 | isEmptyBag ex_tvs && all not_overloaded ex_ids
283 -- Short cut for case when there are no existentials
284 -- and no polymorphic overloaded variables
285 -- e.g. f :: (forall a. Ord a => a -> a) -> Int -> Int
287 -- Here we must discharge op Methods
288 = ASSERT( isEmptyLIE ex_lie )
289 returnTc (lie_req, EmptyMonoBinds)
292 = tcAddErrCtxtM (sigPatCtxt tv_list ex_ids match_ty) $
294 -- In case there are any polymorpic, overloaded binders in the pattern
295 -- (which can happen in the case of rank-2 type signatures, or data constructors
296 -- with polymorphic arguments), we must do a bindInstsOfLocalFns here
297 bindInstsOfLocalFuns lie_req ex_ids `thenTc` \ (lie1, inst_binds) ->
299 -- Deal with overloaded functions bound by the pattern
300 tcSimplifyCheck doc tv_list (lieToList ex_lie) lie1 `thenTc` \ (lie2, dict_binds) ->
301 checkSigTyVarsWrt (tyVarsOfType match_ty) tv_list `thenTc_`
303 returnTc (lie2, dict_binds `AndMonoBinds` inst_binds)
305 doc = text ("existential context of a data constructor")
306 tv_list = bagToList ex_tvs
307 not_overloaded id = not (isOverloadedTy (idType id))
311 %************************************************************************
315 %************************************************************************
317 Typechecking statements is rendered a bit tricky by parallel list comprehensions:
319 [ (g x, h x) | ... ; let g v = ...
320 | ... ; let h v = ... ]
322 It's possible that g,h are overloaded, so we need to feed the LIE from the
323 (g x, h x) up through both lots of bindings (so we get the bindInstsOfLocalFuns).
324 Similarly if we had an existential pattern match:
326 data T = forall a. Show a => C a
328 [ (show x, show y) | ... ; C x <- ...
331 Then we need the LIE from (show x, show y) to be simplified against
332 the bindings for x and y.
334 It's difficult to do this in parallel, so we rely on the renamer to
335 ensure that g,h and x,y don't duplicate, and simply grow the environment.
336 So the binders of the first parallel group will be in scope in the second
337 group. But that's fine; there's no shadowing to worry about.
340 tcStmts do_or_lc m_ty stmts
341 = ASSERT( notNull stmts )
342 tcStmtsAndThen (:) do_or_lc m_ty stmts (returnTc ([], emptyLIE))
345 :: (TcStmt -> thing -> thing) -- Combiner
346 -> RenamedMatchContext
347 -> (TcType -> TcType, TcType) -- m, the relationship type of pat and rhs in pat <- rhs
348 -- elt_ty, where type of the comprehension is (m elt_ty)
354 tcStmtsAndThen combine do_or_lc m_ty [] do_next
357 tcStmtsAndThen combine do_or_lc m_ty (stmt:stmts) do_next
358 = tcStmtAndThen combine do_or_lc m_ty stmt
359 (tcStmtsAndThen combine do_or_lc m_ty stmts do_next)
362 tcStmtAndThen combine do_or_lc m_ty (LetStmt binds) thing_inside
363 = tcBindsAndThen -- No error context, but a binding group is
364 (glue_binds combine) -- rather a large thing for an error context anyway
368 tcStmtAndThen combine do_or_lc m_ty@(m,elt_ty) stmt@(BindStmt pat exp src_loc) thing_inside
369 = tcAddSrcLoc src_loc $
370 tcAddErrCtxt (stmtCtxt do_or_lc stmt) $
371 newTyVarTy liftedTypeKind `thenNF_Tc` \ pat_ty ->
372 tcMonoExpr exp (m pat_ty) `thenTc` \ (exp', exp_lie) ->
373 tcMatchPats [pat] (mkFunTy pat_ty (m elt_ty)) (\ _ ->
374 tcPopErrCtxt thing_inside
375 ) `thenTc` \ ([pat'], thing, lie, dict_binds) ->
376 returnTc (combine (BindStmt pat' exp' src_loc)
377 (glue_binds combine Recursive dict_binds thing),
378 lie `plusLIE` exp_lie)
382 tcStmtAndThen combine do_or_lc m_ty (ParStmtOut bndr_stmts_s) thing_inside
383 = loop bndr_stmts_s `thenTc` \ ((pairs', thing), lie) ->
384 returnTc (combine (ParStmtOut pairs') thing, lie)
387 = thing_inside `thenTc` \ (thing, stmts_lie) ->
388 returnTc (([], thing), stmts_lie)
390 loop ((bndrs,stmts) : pairs)
392 combine_par (DoCtxt ListComp) m_ty stmts
393 -- Notice we pass on m_ty; the result type is used only
394 -- to get escaping type variables for checkExistentialPat
395 (tcLookupLocalIds bndrs `thenNF_Tc` \ bndrs' ->
396 loop pairs `thenTc` \ ((pairs', thing), lie) ->
397 returnTc (([], (bndrs', pairs', thing)), lie)) `thenTc` \ ((stmts', (bndrs', pairs', thing)), lie) ->
399 returnTc ( ((bndrs',stmts') : pairs', thing), lie)
401 combine_par stmt (stmts, thing) = (stmt:stmts, thing)
404 tcStmtAndThen combine do_or_lc m_ty@(m, res_elt_ty) stmt@(ExprStmt exp _ locn) thing_inside
405 = tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
406 if isDoExpr do_or_lc then
407 newTyVarTy openTypeKind `thenNF_Tc` \ any_ty ->
408 tcMonoExpr exp (m any_ty) `thenNF_Tc` \ (exp', lie) ->
409 returnTc (ExprStmt exp' any_ty locn, lie)
411 tcMonoExpr exp boolTy `thenNF_Tc` \ (exp', lie) ->
412 returnTc (ExprStmt exp' boolTy locn, lie)
413 ) `thenTc` \ (stmt', stmt_lie) ->
415 thing_inside `thenTc` \ (thing, stmts_lie) ->
417 returnTc (combine stmt' thing, stmt_lie `plusLIE` stmts_lie)
421 tcStmtAndThen combine do_or_lc m_ty@(m, res_elt_ty) stmt@(ResultStmt exp locn) thing_inside
422 = tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
423 if isDoExpr do_or_lc then
424 tcMonoExpr exp (m res_elt_ty)
426 tcMonoExpr exp res_elt_ty
427 ) `thenTc` \ (exp', stmt_lie) ->
429 thing_inside `thenTc` \ (thing, stmts_lie) ->
431 returnTc (combine (ResultStmt exp' locn) thing,
432 stmt_lie `plusLIE` stmts_lie)
435 ------------------------------
436 glue_binds combine is_rec binds thing
437 | nullMonoBinds binds = thing
438 | otherwise = combine (LetStmt (mkMonoBind binds [] is_rec)) thing
442 %************************************************************************
444 \subsection{Errors and contexts}
446 %************************************************************************
448 @sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same
449 number of args are used in each equation.
452 sameNoOfArgs :: [RenamedMatch] -> Bool
453 sameNoOfArgs matches = isSingleton (nub (map args_in_match matches))
455 args_in_match :: RenamedMatch -> Int
456 args_in_match (Match pats _ _) = length pats
460 varyingArgsErr name matches
461 = sep [ptext SLIT("Varying number of arguments for function"), quotes (ppr name)]
463 matchCtxt ctxt match = hang (pprMatchContext ctxt <> colon) 4 (pprMatch ctxt match)
464 stmtCtxt do_or_lc stmt = hang (pprMatchContext do_or_lc <> colon) 4 (ppr stmt)
466 sigPatCtxt bound_tvs bound_ids match_ty tidy_env
467 = zonkTcType match_ty `thenNF_Tc` \ match_ty' ->
469 (env1, tidy_tys) = tidyOpenTypes tidy_env (map idType show_ids)
470 (env2, tidy_mty) = tidyOpenType env1 match_ty'
473 sep [ptext SLIT("When checking an existential match that binds"),
474 nest 4 (vcat (zipWith ppr_id show_ids tidy_tys)),
475 ptext SLIT("and whose type is") <+> ppr tidy_mty])
477 show_ids = filter is_interesting bound_ids
478 is_interesting id = any (`elemVarSet` idFreeTyVars id) bound_tvs
480 ppr_id id ty = ppr id <+> dcolon <+> ppr ty
481 -- Don't zonk the types so we get the separate, un-unified versions