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, RenamedPat, RenamedHsType,
22 import TcHsSyn ( TcMatch, TcGRHSs, TcStmt, TcDictBinds, TypecheckedPat )
25 import TcMonoType ( kcHsSigTypes, tcScopedTyVars, checkSigTyVars, tcHsSigType, sigPatCtxt )
26 import Inst ( LIE, isEmptyLIE, plusLIE, emptyLIE, plusLIEs, lieToList )
27 import TcEnv ( TcId, tcLookupLocalIds, tcExtendLocalValEnv, tcExtendGlobalTyVars,
29 import TcPat ( tcPat, tcMonoPatBndr, polyPatSig )
30 import TcType ( TcType, newTyVarTy )
31 import TcBinds ( tcBindsAndThen )
32 import TcSimplify ( tcSimplifyCheck, bindInstsOfLocalFuns )
33 import TcUnify ( unifyFunTy, unifyTauTy )
35 import TysWiredIn ( boolTy )
37 import BasicTypes ( RecFlag(..) )
38 import Type ( tyVarsOfType, isTauTy, mkFunTy,
39 liftedTypeKind, openTypeKind, splitSigmaTy )
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 unifyFunTy does that on the fly
83 tcMatches xve matches expected_ty (FunRhs fun_name)
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 [] matches (mkFunTy scrut_ty expr_ty) CaseAlt `thenTc` \ (matches', lie) ->
99 returnTc (scrut_ty, matches', lie)
101 tcMatchLambda :: RenamedMatch -> TcType -> TcM (TcMatch, LIE)
102 tcMatchLambda match res_ty = tcMatch [] match res_ty LambdaExpr
107 tcMatches :: [(Name,Id)]
111 -> TcM ([TcMatch], LIE)
113 tcMatches xve matches expected_ty fun_or_case
114 = mapAndUnzipTc tc_match matches `thenTc` \ (matches, lies) ->
115 returnTc (matches, plusLIEs lies)
117 tc_match match = tcMatch xve match expected_ty fun_or_case
121 %************************************************************************
125 %************************************************************************
128 tcMatch :: [(Name,Id)]
130 -> TcType -- Expected result-type of the Match.
131 -- Early unification with this guy gives better error messages
133 -> TcM (TcMatch, LIE)
135 tcMatch xve1 match@(Match sig_tvs pats maybe_rhs_sig grhss) expected_ty ctxt
136 = tcAddSrcLoc (getMatchLoc match) $ -- At one stage I removed this;
137 tcAddErrCtxt (matchCtxt ctxt match) $ -- I'm not sure why, so I put it back
139 tcMatchPats pats expected_ty tc_grhss `thenTc` \ ((pats', grhss'), lie, ex_binds) ->
140 returnTc (Match [] pats' Nothing (glue_on Recursive ex_binds grhss'), lie)
143 tc_grhss pats' rhs_ty
144 = -- Check that the remaining "expected type" is not a rank-2 type
145 -- If it is it'll mess up the unifier when checking the RHS
146 checkTc (isTauTy rhs_ty) lurkingRank2SigErr `thenTc_`
148 -- Deal with the result signature
149 tc_result_sig maybe_rhs_sig (
151 -- Typecheck the body
152 tcExtendLocalValEnv xve1 $
153 tcGRHSs grhss rhs_ty ctxt `thenTc` \ (grhss', lie) ->
154 returnTc ((pats', grhss'), lie)
157 tc_result_sig Nothing thing_inside
159 tc_result_sig (Just sig) thing_inside
160 = tcAddScopedTyVars [sig] $
161 tcHsSigType sig `thenTc` \ sig_ty ->
163 -- Check that the signature isn't a polymorphic one, which
164 -- we don't permit (at present, anyway)
165 checkTc (isTauTy sig_ty) (polyPatSig sig_ty) `thenTc_`
166 unifyTauTy expected_ty sig_ty `thenTc_`
170 -- glue_on just avoids stupid dross
171 glue_on _ EmptyMonoBinds grhss = grhss -- The common case
172 glue_on is_rec mbinds (GRHSs grhss binds ty)
173 = GRHSs grhss (mkMonoBind mbinds [] is_rec `ThenBinds` binds) ty
175 tcGRHSs :: RenamedGRHSs
176 -> TcType -> HsMatchContext
177 -> TcM (TcGRHSs, LIE)
179 tcGRHSs (GRHSs grhss binds _) expected_ty ctxt
180 = tcBindsAndThen glue_on binds (tc_grhss grhss)
183 = mapAndUnzipTc tc_grhs grhss `thenTc` \ (grhss', lies) ->
184 returnTc (GRHSs grhss' EmptyBinds (Just expected_ty), plusLIEs lies)
186 tc_grhs (GRHS guarded locn)
188 tcStmts ctxt (\ty -> ty, expected_ty) guarded `thenTc` \ (guarded', lie) ->
189 returnTc (GRHS guarded' locn, lie)
193 %************************************************************************
195 \subsection{tcMatchPats}
197 %************************************************************************
201 :: [RenamedPat] -> TcType
202 -> ([TypecheckedPat] -> TcType -> TcM (a, LIE))
203 -> TcM (a, LIE, TcDictBinds)
204 -- Typecheck the patterns, extend the environment to bind the variables,
205 -- do the thing inside, use any existentially-bound dictionaries to
206 -- discharge parts of the returning LIE, and deal with pattern type
209 tcMatchPats pats expected_ty thing_inside
210 = -- STEP 1: Bring pattern-signature type variables into scope
211 tcAddScopedTyVars (collectSigTysFromPats pats) $
213 -- STEP 2: Typecheck the patterns themselves, gathering all the stuff
214 tc_match_pats pats expected_ty `thenTc` \ (rhs_ty, pats', lie_req1, ex_tvs, pat_bndrs, lie_avail) ->
216 -- STEP 3: Extend the environment, and do the thing inside
218 xve = bagToList pat_bndrs
219 pat_ids = map snd xve
221 tcExtendLocalValEnv xve (thing_inside pats' rhs_ty) `thenTc` \ (result, lie_req2) ->
223 -- STEP 4: Check for existentially bound type variables
224 -- I'm a bit concerned that lie_req1 from an 'inner' pattern in the list
225 -- might need (via lie_req2) something made available from an 'outer'
226 -- pattern. But it's inconvenient to deal with, and I can't find an example
227 tcCheckExistentialPat pat_ids ex_tvs lie_avail lie_req1 rhs_ty `thenTc` \ (lie_req1', ex_binds) ->
229 returnTc (result, lie_req1' `plusLIE` lie_req2, ex_binds)
231 tcAddScopedTyVars :: [RenamedHsType] -> TcM a -> TcM a
232 -- Find the not-already-in-scope signature type variables,
233 -- kind-check them, and bring them into scope
235 -- We no longer specify that these type variables must be univerally
236 -- quantified (lots of email on the subject). If you want to put that
237 -- back in, you need to
238 -- a) Do a checkSigTyVars after thing_inside
239 -- b) More insidiously, don't pass in expected_ty, else
240 -- we unify with it too early and checkSigTyVars barfs
241 -- Instead you have to pass in a fresh ty var, and unify
242 -- it with expected_ty afterwards
243 tcAddScopedTyVars sig_tys thing_inside
244 = tcGetEnv `thenNF_Tc` \ env ->
246 all_sig_tvs = foldr (unionNameSets . extractHsTyVars) emptyNameSet sig_tys
247 sig_tvs = filter not_in_scope (nameSetToList all_sig_tvs)
248 not_in_scope tv = not (tcInLocalScope env tv)
250 tcScopedTyVars sig_tvs (kcHsSigTypes sig_tys) thing_inside
252 tcCheckExistentialPat :: [TcId] -- Ids bound by this pattern
253 -> Bag TcTyVar -- Existentially quantified tyvars bound by pattern
254 -> LIE -- and context
255 -> LIE -- Required context
256 -> TcType -- and result type; vars in here must not escape
257 -> TcM (LIE, TcDictBinds) -- LIE to float out and dict bindings
258 tcCheckExistentialPat ids ex_tvs lie_avail lie_req result_ty
259 | isEmptyBag ex_tvs && all not_overloaded ids
260 -- Short cut for case when there are no existentials
261 -- and no polymorphic overloaded variables
262 -- e.g. f :: (forall a. Ord a => a -> a) -> Int -> Int
264 -- Here we must discharge op Methods
265 = ASSERT( isEmptyLIE lie_avail )
266 returnTc (lie_req, EmptyMonoBinds)
269 = tcExtendGlobalTyVars (tyVarsOfType result_ty) $
270 tcAddErrCtxtM (sigPatCtxt tv_list ids) $
272 -- In case there are any polymorpic, overloaded binders in the pattern
273 -- (which can happen in the case of rank-2 type signatures, or data constructors
274 -- with polymorphic arguments), we must do a bindInstsOfLocalFns here
275 bindInstsOfLocalFuns lie_req ids `thenTc` \ (lie1, inst_binds) ->
277 -- Deal with overloaded functions bound by the pattern
278 tcSimplifyCheck doc tv_list
279 (lieToList lie_avail) lie1 `thenTc` \ (lie2, dict_binds) ->
280 checkSigTyVars tv_list emptyVarSet `thenTc_`
282 returnTc (lie2, dict_binds `AndMonoBinds` inst_binds)
284 doc = text ("the existential context of a data constructor")
285 tv_list = bagToList ex_tvs
286 not_overloaded id = case splitSigmaTy (idType id) of
287 (_, theta, _) -> null theta
289 tc_match_pats [] expected_ty
290 = returnTc (expected_ty, [], emptyLIE, emptyBag, emptyBag, emptyLIE)
292 tc_match_pats (pat:pats) expected_ty
293 = unifyFunTy expected_ty `thenTc` \ (arg_ty, rest_ty) ->
294 tcPat tcMonoPatBndr pat arg_ty `thenTc` \ (pat', lie_req, pat_tvs, pat_ids, lie_avail) ->
295 tc_match_pats pats rest_ty `thenTc` \ (rhs_ty, pats', lie_reqs, pats_tvs, pats_ids, lie_avails) ->
298 lie_req `plusLIE` lie_reqs,
299 pat_tvs `unionBags` pats_tvs,
300 pat_ids `unionBags` pats_ids,
301 lie_avail `plusLIE` lie_avails
306 %************************************************************************
310 %************************************************************************
312 Typechecking statements is rendered a bit tricky by parallel list comprehensions:
314 [ (g x, h x) | ... ; let g v = ...
315 | ... ; let h v = ... ]
317 It's possible that g,h are overloaded, so we need to feed the LIE from the
318 (g x, h x) up through both lots of bindings (so we get the bindInstsOfLocalFuns).
319 Similarly if we had an existential pattern match:
321 data T = forall a. Show a => C a
323 [ (show x, show y) | ... ; C x <- ...
326 Then we need the LIE from (show x, show y) to be simplified against
327 the bindings for x and y.
329 It's difficult to do this in parallel, so we rely on the renamer to
330 ensure that g,h and x,y don't duplicate, and simply grow the environment.
331 So the binders of the first parallel group will be in scope in the second
332 group. But that's fine; there's no shadowing to worry about.
335 tcStmts do_or_lc m_ty stmts
336 = tcStmtsAndThen (:) do_or_lc m_ty stmts (returnTc ([], emptyLIE))
339 :: (TcStmt -> thing -> thing) -- Combiner
341 -> (TcType -> TcType, TcType) -- m, the relationship type of pat and rhs in pat <- rhs
342 -- elt_ty, where type of the comprehension is (m elt_ty)
348 tcStmtsAndThen combine do_or_lc m_ty [] do_next
351 tcStmtsAndThen combine do_or_lc m_ty (stmt:stmts) do_next
352 = tcStmtAndThen combine do_or_lc m_ty stmt
353 (tcStmtsAndThen combine do_or_lc m_ty stmts do_next)
356 tcStmtAndThen combine do_or_lc m_ty (LetStmt binds) thing_inside
357 = tcBindsAndThen -- No error context, but a binding group is
358 (glue_binds combine) -- rather a large thing for an error context anyway
362 tcStmtAndThen combine do_or_lc m_ty@(m,elt_ty) stmt@(BindStmt pat exp src_loc) thing_inside
363 = tcAddSrcLoc src_loc $
364 tcAddErrCtxt (stmtCtxt do_or_lc stmt) $
365 newTyVarTy liftedTypeKind `thenNF_Tc` \ pat_ty ->
366 tcExpr exp (m pat_ty) `thenTc` \ (exp', exp_lie) ->
367 tcMatchPats [pat] (mkFunTy pat_ty (m elt_ty)) (\ [pat'] _ ->
369 thing_inside `thenTc` \ (thing, lie) ->
370 returnTc ((BindStmt pat' exp' src_loc, thing), lie)
371 ) `thenTc` \ ((stmt', thing), lie, dict_binds) ->
372 returnTc (combine stmt' (glue_binds combine Recursive dict_binds thing),
373 lie `plusLIE` exp_lie)
377 tcStmtAndThen combine do_or_lc m_ty (ParStmtOut bndr_stmts_s) thing_inside
378 = loop bndr_stmts_s `thenTc` \ ((pairs', thing), lie) ->
379 returnTc (combine (ParStmtOut pairs') thing, lie)
382 = thing_inside `thenTc` \ (thing, stmts_lie) ->
383 returnTc (([], thing), stmts_lie)
385 loop ((bndrs,stmts) : pairs)
387 combine_par ListComp m_ty stmts
388 -- Notice we pass on m_ty; the result type is used only
389 -- to get escaping type variables for checkExistentialPat
390 (tcLookupLocalIds bndrs `thenNF_Tc` \ bndrs' ->
391 loop pairs `thenTc` \ ((pairs', thing), lie) ->
392 returnTc (([], (bndrs', pairs', thing)), lie)) `thenTc` \ ((stmts', (bndrs', pairs', thing)), lie) ->
394 returnTc ( ((bndrs',stmts') : pairs', thing), lie)
396 combine_par stmt (stmts, thing) = (stmt:stmts, thing)
399 tcStmtAndThen combine do_or_lc m_ty@(m, res_elt_ty) stmt@(ExprStmt exp locn) thing_inside
400 = tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
401 if isDoExpr do_or_lc then
402 newTyVarTy openTypeKind `thenNF_Tc` \ any_ty ->
403 tcExpr exp (m any_ty)
406 ) `thenTc` \ (exp', stmt_lie) ->
408 thing_inside `thenTc` \ (thing, stmts_lie) ->
410 returnTc (combine (ExprStmt exp' locn) thing,
411 stmt_lie `plusLIE` stmts_lie)
415 tcStmtAndThen combine do_or_lc m_ty@(m, res_elt_ty) stmt@(ResultStmt exp locn) thing_inside
416 = tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
417 if isDoExpr do_or_lc then
418 tcExpr exp (m res_elt_ty)
420 tcExpr exp res_elt_ty
421 ) `thenTc` \ (exp', stmt_lie) ->
423 thing_inside `thenTc` \ (thing, stmts_lie) ->
425 returnTc (combine (ResultStmt exp' locn) thing,
426 stmt_lie `plusLIE` stmts_lie)
429 ------------------------------
430 glue_binds combine is_rec binds thing
431 | nullMonoBinds binds = thing
432 | otherwise = combine (LetStmt (mkMonoBind binds [] is_rec)) thing
436 %************************************************************************
438 \subsection{Errors and contexts}
440 %************************************************************************
442 @sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same
443 number of args are used in each equation.
446 sameNoOfArgs :: [RenamedMatch] -> Bool
447 sameNoOfArgs matches = length (nub (map args_in_match matches)) == 1
449 args_in_match :: RenamedMatch -> Int
450 args_in_match (Match _ pats _ _) = length pats
454 matchCtxt CaseAlt match
455 = hang (ptext SLIT("In a case alternative:"))
456 4 (pprMatch (True,empty) {-is_case-} match)
458 matchCtxt (FunRhs fun) match
459 = hang (hcat [ptext SLIT("In an equation for function "), quotes (ppr_fun), char ':'])
460 4 (pprMatch (False, ppr_fun) {-not case-} match)
464 matchCtxt LambdaExpr match
465 = hang (ptext SLIT("In the lambda expression"))
466 4 (pprMatch (True, empty) match)
468 varyingArgsErr name matches
469 = sep [ptext SLIT("Varying number of arguments for function"), quotes (ppr name)]
472 = ptext SLIT("Too few explicit arguments when defining a function with a rank-2 type")
474 stmtCtxt do_or_lc stmt = hang (pprMatchContext do_or_lc <> colon) 4 (ppr stmt)