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( tcExpr )
15 import HsSyn ( HsBinds(..), Match(..), GRHSs(..), GRHS(..),
16 MonoBinds(..), Stmt(..), HsMatchContext(..),
17 pprMatch, getMatchLoc, pprMatchContext, isDoExpr,
18 mkMonoBind, nullMonoBinds, collectSigTysFromPats
20 import RnHsSyn ( RenamedMatch, RenamedGRHSs, RenamedStmt )
21 import TcHsSyn ( TcMatch, TcGRHSs, TcStmt, TcDictBinds )
24 import TcMonoType ( kcHsSigType, tcTyVars, checkSigTyVars, tcHsSigType, sigPatCtxt )
25 import Inst ( LIE, isEmptyLIE, plusLIE, emptyLIE, plusLIEs, lieToList )
26 import TcEnv ( TcId, tcLookupLocalIds, tcExtendTyVarEnv, tcExtendLocalValEnv, tcExtendGlobalTyVars )
27 import TcPat ( tcPat, tcMonoPatBndr, polyPatSig )
28 import TcType ( TcType, newTyVarTy )
29 import TcBinds ( tcBindsAndThen )
30 import TcSimplify ( tcSimplifyCheck, bindInstsOfLocalFuns )
31 import TcUnify ( unifyFunTy, unifyTauTy )
33 import TysWiredIn ( boolTy, mkListTy )
35 import BasicTypes ( RecFlag(..) )
36 import Type ( tyVarsOfType, isTauTy, mkFunTy,
37 liftedTypeKind, openTypeKind, splitSigmaTy )
45 %************************************************************************
47 \subsection{tcMatchesFun, tcMatchesCase}
49 %************************************************************************
51 @tcMatchesFun@ typechecks a @[Match]@ list which occurs in a
52 @FunMonoBind@. The second argument is the name of the function, which
53 is used in error messages. It checks that all the equations have the
54 same number of arguments before using @tcMatches@ to do the work.
57 tcMatchesFun :: [(Name,Id)] -- Bindings for the variables bound in this group
59 -> TcType -- Expected type
61 -> TcM ([TcMatch], LIE)
63 tcMatchesFun xve fun_name expected_ty matches@(first_match:_)
64 = -- Check that they all have the same no of arguments
65 -- Set the location to that of the first equation, so that
66 -- any inter-equation error messages get some vaguely
67 -- sensible location. Note: we have to do this odd
68 -- ann-grabbing, because we don't always have annotations in
69 -- hand when we call tcMatchesFun...
70 tcAddSrcLoc (getMatchLoc first_match) (
71 checkTc (sameNoOfArgs matches)
72 (varyingArgsErr fun_name matches)
75 -- ToDo: Don't use "expected" stuff if there ain't a type signature
76 -- because inconsistency between branches
77 -- may show up as something wrong with the (non-existent) type signature
79 -- No need to zonk expected_ty, because unifyFunTy does that on the fly
80 tcMatches xve matches expected_ty (FunRhs fun_name)
83 @tcMatchesCase@ doesn't do the argument-count check because the
84 parser guarantees that each equation has exactly one argument.
87 tcMatchesCase :: [RenamedMatch] -- The case alternatives
88 -> TcType -- Type of whole case expressions
89 -> TcM (TcType, -- Inferred type of the scrutinee
90 [TcMatch], -- Translated alternatives
93 tcMatchesCase matches expr_ty
94 = newTyVarTy openTypeKind `thenNF_Tc` \ scrut_ty ->
95 tcMatches [] matches (mkFunTy scrut_ty expr_ty) CaseAlt `thenTc` \ (matches', lie) ->
96 returnTc (scrut_ty, matches', lie)
98 tcMatchLambda :: RenamedMatch -> TcType -> TcM (TcMatch, LIE)
99 tcMatchLambda match res_ty = tcMatch [] match res_ty LambdaExpr
104 tcMatches :: [(Name,Id)]
108 -> TcM ([TcMatch], LIE)
110 tcMatches xve matches expected_ty fun_or_case
111 = mapAndUnzipTc tc_match matches `thenTc` \ (matches, lies) ->
112 returnTc (matches, plusLIEs lies)
114 tc_match match = tcMatch xve match expected_ty fun_or_case
118 %************************************************************************
122 %************************************************************************
125 tcMatch :: [(Name,Id)]
127 -> TcType -- Expected result-type of the Match.
128 -- Early unification with this guy gives better error messages
130 -> TcM (TcMatch, LIE)
132 tcMatch xve1 match@(Match sig_tvs pats maybe_rhs_sig grhss) expected_ty ctxt
133 = tcAddSrcLoc (getMatchLoc match) $
134 tcAddErrCtxt (matchCtxt ctxt match) $
136 if null sig_tvs then -- The common case
137 tc_match expected_ty `thenTc` \ (_, match_and_lie) ->
138 returnTc match_and_lie
141 -- If there are sig tvs we must be careful *not* to use
142 -- expected_ty right away, else we'll unify with tyvars free
143 -- in the envt. So invent a fresh tyvar and use that instead
144 newTyVarTy openTypeKind `thenNF_Tc` \ tyvar_ty ->
146 -- Extend the tyvar env and check the match itself
147 tcTyVars sig_tvs (mapTc_ kcHsSigType sig_tys) `thenTc` \ sig_tyvars ->
148 tcExtendTyVarEnv sig_tyvars (tc_match tyvar_ty) `thenTc` \ (pat_ids, match_and_lie) ->
150 -- Check that the scoped type variables from the patterns
151 -- have not been constrained
152 tcAddErrCtxtM (sigPatCtxt sig_tyvars pat_ids) (
153 checkSigTyVars sig_tyvars emptyVarSet
156 -- *Now* we're free to unify with expected_ty
157 unifyTauTy expected_ty tyvar_ty `thenTc_`
159 returnTc match_and_lie
162 sig_tys = case maybe_rhs_sig of { Just t -> [t]; Nothing -> [] }
163 ++ collectSigTysFromPats pats
165 tc_match expected_ty -- Any sig tyvars are in scope by now
166 = -- STEP 1: Typecheck the patterns
167 tcMatchPats pats expected_ty `thenTc` \ (rhs_ty, pats', lie_req1, ex_tvs, pat_bndrs, lie_avail) ->
169 xve2 = bagToList pat_bndrs
170 pat_ids = map snd xve2
173 -- STEP 2: Check that the remaining "expected type" is not a rank-2 type
174 -- If it is it'll mess up the unifier when checking the RHS
175 checkTc (isTauTy rhs_ty) lurkingRank2SigErr `thenTc_`
177 -- STEP 3: Unify with the rhs type signature if any
178 (case maybe_rhs_sig of
179 Nothing -> returnTc ()
180 Just sig -> tcHsSigType sig `thenTc` \ sig_ty ->
182 -- Check that the signature isn't a polymorphic one, which
183 -- we don't permit (at present, anyway)
184 checkTc (isTauTy sig_ty) (polyPatSig sig_ty) `thenTc_`
185 unifyTauTy rhs_ty sig_ty
188 -- STEP 4: Typecheck the guarded RHSs and the associated where clause
189 tcExtendLocalValEnv xve1 (tcExtendLocalValEnv xve2 (
190 tcGRHSs grhss rhs_ty ctxt
191 )) `thenTc` \ (grhss', lie_req2) ->
193 -- STEP 5: Check for existentially bound type variables
194 tcCheckExistentialPat pat_ids ex_tvs lie_avail
195 (lie_req1 `plusLIE` lie_req2)
196 rhs_ty `thenTc` \ (lie_req', ex_binds) ->
200 match' = Match [] pats' Nothing (glue_on Recursive ex_binds grhss')
202 returnTc (pat_ids, (match', lie_req'))
204 -- glue_on just avoids stupid dross
205 glue_on _ EmptyMonoBinds grhss = grhss -- The common case
206 glue_on is_rec mbinds (GRHSs grhss binds ty)
207 = GRHSs grhss (mkMonoBind mbinds [] is_rec `ThenBinds` binds) ty
209 tcGRHSs :: RenamedGRHSs
210 -> TcType -> HsMatchContext
211 -> TcM (TcGRHSs, LIE)
213 tcGRHSs (GRHSs grhss binds _) expected_ty ctxt
214 = tcBindsAndThen glue_on binds (tc_grhss grhss)
217 = mapAndUnzipTc tc_grhs grhss `thenTc` \ (grhss', lies) ->
218 returnTc (GRHSs grhss' EmptyBinds (Just expected_ty), plusLIEs lies)
220 tc_grhs (GRHS guarded locn)
222 tcStmts ctxt (\ty -> ty, expected_ty) guarded `thenTc` \ (guarded', lie) ->
223 returnTc (GRHS guarded' locn, lie)
226 tcCheckExistentialPat :: [TcId] -- Ids bound by this pattern
227 -> Bag TcTyVar -- Existentially quantified tyvars bound by pattern
228 -> LIE -- and context
229 -> LIE -- Required context
230 -> TcType -- and result type; vars in here must not escape
231 -> TcM (LIE, TcDictBinds) -- LIE to float out and dict bindings
232 tcCheckExistentialPat ids ex_tvs lie_avail lie_req result_ty
233 | isEmptyBag ex_tvs && all not_overloaded ids
234 -- Short cut for case when there are no existentials
235 -- and no polymorphic overloaded variables
236 -- e.g. f :: (forall a. Ord a => a -> a) -> Int -> Int
238 -- Here we must discharge op Methods
239 = ASSERT( isEmptyLIE lie_avail )
240 returnTc (lie_req, EmptyMonoBinds)
243 = tcExtendGlobalTyVars (tyVarsOfType result_ty) $
244 tcAddErrCtxtM (sigPatCtxt tv_list ids) $
246 -- In case there are any polymorpic, overloaded binders in the pattern
247 -- (which can happen in the case of rank-2 type signatures, or data constructors
248 -- with polymorphic arguments), we must do a bindInstsOfLocalFns here
249 bindInstsOfLocalFuns lie_req ids `thenTc` \ (lie1, inst_binds) ->
251 -- Deal with overloaded functions bound by the pattern
252 tcSimplifyCheck doc tv_list
253 (lieToList lie_avail) lie1 `thenTc` \ (lie2, dict_binds) ->
254 checkSigTyVars tv_list emptyVarSet `thenTc_`
256 returnTc (lie2, dict_binds `AndMonoBinds` inst_binds)
258 doc = text ("the existential context of a data constructor")
259 tv_list = bagToList ex_tvs
260 not_overloaded id = case splitSigmaTy (idType id) of
261 (_, theta, _) -> null theta
265 %************************************************************************
267 \subsection{tcMatchPats}
269 %************************************************************************
272 tcMatchPats [] expected_ty
273 = returnTc (expected_ty, [], emptyLIE, emptyBag, emptyBag, emptyLIE)
275 tcMatchPats (pat:pats) expected_ty
276 = unifyFunTy expected_ty `thenTc` \ (arg_ty, rest_ty) ->
277 tcPat tcMonoPatBndr pat arg_ty `thenTc` \ (pat', lie_req, pat_tvs, pat_ids, lie_avail) ->
278 tcMatchPats pats rest_ty `thenTc` \ (rhs_ty, pats', lie_reqs, pats_tvs, pats_ids, lie_avails) ->
281 lie_req `plusLIE` lie_reqs,
282 pat_tvs `unionBags` pats_tvs,
283 pat_ids `unionBags` pats_ids,
284 lie_avail `plusLIE` lie_avails
289 %************************************************************************
293 %************************************************************************
295 Typechecking statements is rendered a bit tricky by parallel list comprehensions:
297 [ (g x, h x) | ... ; let g v = ...
298 | ... ; let h v = ... ]
300 It's possible that g,h are overloaded, so we need to feed the LIE from the
301 (g x, h x) up through both lots of bindings (so we get the bindInstsOfLocalFuns).
302 Similarly if we had an existential pattern match:
304 data T = forall a. Show a => C a
306 [ (show x, show y) | ... ; C x <- ...
309 Then we need the LIE from (show x, show y) to be simplified against
310 the bindings for x and y.
312 It's difficult to do this in parallel, so we rely on the renamer to
313 ensure that g,h and x,y don't duplicate, and simply grow the environment.
314 So the binders of the first parallel group will be in scope in the second
315 group. But that's fine; there's no shadowing to worry about.
318 tcStmts do_or_lc m_ty stmts
319 = tcStmtsAndThen (:) do_or_lc m_ty stmts (returnTc ([], emptyLIE))
322 :: (TcStmt -> thing -> thing) -- Combiner
324 -> (TcType -> TcType, TcType) -- m, the relationship type of pat and rhs in pat <- rhs
325 -- elt_ty, where type of the comprehension is (m elt_ty)
331 tcStmtsAndThen combine do_or_lc m_ty [] do_next
335 tcStmtsAndThen combine do_or_lc m_ty (LetStmt binds : stmts) do_next
336 = tcBindsAndThen -- No error context, but a binding group is
337 (glue_binds combine) -- rather a large thing for an error context anyway
339 (tcStmtsAndThen combine do_or_lc m_ty stmts do_next)
342 tcStmtsAndThen combine do_or_lc m_ty@(m,elt_ty) (stmt@(BindStmt pat exp src_loc) : stmts) do_next
343 = tcAddSrcLoc src_loc (
344 tcSetErrCtxt (stmtCtxt do_or_lc stmt) $
345 newTyVarTy liftedTypeKind `thenNF_Tc` \ pat_ty ->
346 tcPat tcMonoPatBndr pat pat_ty `thenTc` \ (pat', pat_lie, pat_tvs, pat_ids, avail) ->
347 tcExpr exp (m pat_ty) `thenTc` \ (exp', exp_lie) ->
348 returnTc (pat', exp',
349 pat_lie `plusLIE` exp_lie,
350 pat_tvs, pat_ids, avail)
351 ) `thenTc` \ (pat', exp', lie_req, pat_tvs, pat_bndrs, lie_avail) ->
353 new_val_env = bagToList pat_bndrs
354 pat_ids = map snd new_val_env
357 -- Do the rest; we don't need to add the pat_tvs to the envt
358 -- because they all appear in the pat_ids's types
359 tcExtendLocalValEnv new_val_env (
360 tcStmtsAndThen combine do_or_lc m_ty stmts do_next
361 ) `thenTc` \ (thing, stmts_lie) ->
363 -- Reinstate context for existential checks
364 tcSetErrCtxt (stmtCtxt do_or_lc stmt) $
365 tcCheckExistentialPat pat_ids pat_tvs lie_avail
366 stmts_lie (m elt_ty) `thenTc` \ (final_lie, dict_binds) ->
368 returnTc (combine (BindStmt pat' exp' src_loc)
369 (glue_binds combine Recursive dict_binds thing),
370 lie_req `plusLIE` final_lie)
374 tcStmtsAndThen combine do_or_lc m_ty (ParStmtOut bndr_stmts_s : stmts) do_next
375 = loop bndr_stmts_s `thenTc` \ ((pairs', thing), lie) ->
376 returnTc (combine (ParStmtOut pairs') thing, lie)
379 = tcStmtsAndThen combine do_or_lc m_ty stmts do_next `thenTc` \ (thing, stmts_lie) ->
380 returnTc (([], thing), stmts_lie)
382 loop ((bndrs,stmts) : pairs)
384 combine_par ListComp (mkListTy, not_required) stmts
385 (tcLookupLocalIds bndrs `thenNF_Tc` \ bndrs' ->
386 loop pairs `thenTc` \ ((pairs', thing), lie) ->
387 returnTc (([], (bndrs', pairs', thing)), lie)) `thenTc` \ ((stmts', (bndrs', pairs', thing)), lie) ->
389 returnTc ( ((bndrs',stmts') : pairs', thing), lie)
391 combine_par stmt (stmts, thing) = (stmt:stmts, thing)
392 not_required = panic "tcStmtsAndThen: elt_ty"
394 -- The simple-statment case
395 tcStmtsAndThen combine do_or_lc m_ty (stmt@(ExprStmt exp locn):stmts) do_next
396 = tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
397 tcExprStmt do_or_lc m_ty exp (null stmts)
398 ) `thenTc` \ (exp', stmt_lie) ->
400 tcStmtsAndThen combine do_or_lc m_ty stmts do_next `thenTc` \ (thing, stmts_lie) ->
402 returnTc (combine (ExprStmt exp' locn) thing,
403 stmt_lie `plusLIE` stmts_lie)
406 ------------------------------
407 -- ExprStmt; see comments with HsExpr.HsStmt
408 -- for meaning of ExprStmt
409 tcExprStmt do_or_lc (m, res_elt_ty) exp is_last_stmt
410 = compute_expr_ty `thenNF_Tc` \ expr_ty ->
414 | is_last_stmt = if isDoExpr do_or_lc then
415 returnNF_Tc (m res_elt_ty)
417 returnNF_Tc res_elt_ty
419 | otherwise = if isDoExpr do_or_lc then
420 newTyVarTy openTypeKind `thenNF_Tc` \ any_ty ->
421 returnNF_Tc (m any_ty)
425 ------------------------------
426 glue_binds combine is_rec binds thing
427 | nullMonoBinds binds = thing
428 | otherwise = combine (LetStmt (mkMonoBind binds [] is_rec)) thing
432 %************************************************************************
434 \subsection{Errors and contexts}
436 %************************************************************************
438 @sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same
439 number of args are used in each equation.
442 sameNoOfArgs :: [RenamedMatch] -> Bool
443 sameNoOfArgs matches = length (nub (map args_in_match matches)) == 1
445 args_in_match :: RenamedMatch -> Int
446 args_in_match (Match _ pats _ _) = length pats
450 matchCtxt CaseAlt match
451 = hang (ptext SLIT("In a case alternative:"))
452 4 (pprMatch (True,empty) {-is_case-} match)
454 matchCtxt (FunRhs fun) match
455 = hang (hcat [ptext SLIT("In an equation for function "), quotes (ppr_fun), char ':'])
456 4 (pprMatch (False, ppr_fun) {-not case-} match)
460 matchCtxt LambdaExpr match
461 = hang (ptext SLIT("In the lambda expression"))
462 4 (pprMatch (True, empty) match)
464 varyingArgsErr name matches
465 = sep [ptext SLIT("Varying number of arguments for function"), quotes (ppr name)]
468 = ptext SLIT("Too few explicit arguments when defining a function with a rank-2 type")
470 stmtCtxt do_or_lc stmt = hang (pprMatchContext do_or_lc <> colon) 4 (ppr stmt)