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(..), HsDoContext(..),
17 pprMatch, getMatchLoc, pprMatchContext, isDoExpr,
18 mkMonoBind, nullMonoBinds, collectSigTysFromPats
20 import RnHsSyn ( RenamedMatch, RenamedGRHSs, RenamedStmt, RenamedPat, RenamedHsType,
21 RenamedMatchContext, extractHsTyVars )
22 import TcHsSyn ( TcMatch, TcGRHSs, TcStmt, TcDictBinds, TypecheckedPat, TypecheckedMatchContext )
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 TcMType ( newTyVarTy, unifyFunTy, unifyTauTy )
31 import TcType ( tyVarsOfType, isTauTy, mkFunTy, isOverloadedTy,
32 liftedTypeKind, openTypeKind )
33 import TcBinds ( tcBindsAndThen )
34 import TcSimplify ( tcSimplifyCheck, bindInstsOfLocalFuns )
36 import TysWiredIn ( boolTy )
38 import BasicTypes ( RecFlag(..) )
47 %************************************************************************
49 \subsection{tcMatchesFun, tcMatchesCase}
51 %************************************************************************
53 @tcMatchesFun@ typechecks a @[Match]@ list which occurs in a
54 @FunMonoBind@. The second argument is the name of the function, which
55 is used in error messages. It checks that all the equations have the
56 same number of arguments before using @tcMatches@ to do the work.
59 tcMatchesFun :: [(Name,Id)] -- Bindings for the variables bound in this group
61 -> TcType -- Expected type
63 -> TcM ([TcMatch], LIE)
65 tcMatchesFun xve fun_name expected_ty matches@(first_match:_)
66 = -- Check that they all have the same no of arguments
67 -- Set the location to that of the first equation, so that
68 -- any inter-equation error messages get some vaguely
69 -- sensible location. Note: we have to do this odd
70 -- ann-grabbing, because we don't always have annotations in
71 -- hand when we call tcMatchesFun...
72 tcAddSrcLoc (getMatchLoc first_match) (
73 checkTc (sameNoOfArgs matches)
74 (varyingArgsErr fun_name matches)
77 -- ToDo: Don't use "expected" stuff if there ain't a type signature
78 -- because inconsistency between branches
79 -- may show up as something wrong with the (non-existent) type signature
81 -- No need to zonk expected_ty, because unifyFunTy does that on the fly
82 tcMatches xve (FunRhs fun_name) matches expected_ty
85 @tcMatchesCase@ doesn't do the argument-count check because the
86 parser guarantees that each equation has exactly one argument.
89 tcMatchesCase :: [RenamedMatch] -- The case alternatives
90 -> TcType -- Type of whole case expressions
91 -> TcM (TcType, -- Inferred type of the scrutinee
92 [TcMatch], -- Translated alternatives
95 tcMatchesCase matches expr_ty
96 = newTyVarTy openTypeKind `thenNF_Tc` \ scrut_ty ->
97 tcMatches [] CaseAlt matches (mkFunTy scrut_ty expr_ty) `thenTc` \ (matches', lie) ->
98 returnTc (scrut_ty, matches', lie)
100 tcMatchLambda :: RenamedMatch -> TcType -> TcM (TcMatch, LIE)
101 tcMatchLambda match res_ty = tcMatch [] LambdaExpr match res_ty
106 tcMatches :: [(Name,Id)]
107 -> RenamedMatchContext
110 -> TcM ([TcMatch], LIE)
112 tcMatches xve fun_or_case matches expected_ty
113 = mapAndUnzipTc tc_match matches `thenTc` \ (matches, lies) ->
114 returnTc (matches, plusLIEs lies)
116 tc_match match = tcMatch xve fun_or_case match expected_ty
120 %************************************************************************
124 %************************************************************************
127 tcMatch :: [(Name,Id)]
128 -> RenamedMatchContext
130 -> TcType -- Expected result-type of the Match.
131 -- Early unification with this guy gives better error messages
132 -> TcM (TcMatch, LIE)
134 tcMatch xve1 ctxt match@(Match sig_tvs pats maybe_rhs_sig grhss) expected_ty
135 = tcAddSrcLoc (getMatchLoc match) $ -- At one stage I removed this;
136 tcAddErrCtxt (matchCtxt ctxt match) $ -- I'm not sure why, so I put it back
138 tcMatchPats pats expected_ty tc_grhss `thenTc` \ ((pats', grhss'), lie, ex_binds) ->
139 returnTc (Match [] pats' Nothing (glue_on Recursive ex_binds grhss'), lie)
142 tc_grhss pats' rhs_ty
143 = -- Check that the remaining "expected type" is not a rank-2 type
144 -- If it is it'll mess up the unifier when checking the RHS
145 checkTc (isTauTy rhs_ty) lurkingRank2SigErr `thenTc_`
147 -- Deal with the result signature
148 tc_result_sig maybe_rhs_sig (
150 -- Typecheck the body
151 tcExtendLocalValEnv xve1 $
152 tcGRHSs ctxt grhss rhs_ty `thenTc` \ (grhss', lie) ->
153 returnTc ((pats', grhss'), lie)
156 tc_result_sig Nothing thing_inside
158 tc_result_sig (Just sig) thing_inside
159 = tcAddScopedTyVars [sig] $
160 tcHsSigType sig `thenTc` \ sig_ty ->
162 -- Check that the signature isn't a polymorphic one, which
163 -- we don't permit (at present, anyway)
164 checkTc (isTauTy sig_ty) (polyPatSig sig_ty) `thenTc_`
165 unifyTauTy expected_ty sig_ty `thenTc_`
169 -- glue_on just avoids stupid dross
170 glue_on _ EmptyMonoBinds grhss = grhss -- The common case
171 glue_on is_rec mbinds (GRHSs grhss binds ty)
172 = GRHSs grhss (mkMonoBind mbinds [] is_rec `ThenBinds` binds) ty
174 tcGRHSs :: RenamedMatchContext -> RenamedGRHSs
176 -> TcM (TcGRHSs, LIE)
178 tcGRHSs ctxt (GRHSs grhss binds _) expected_ty
179 = tcBindsAndThen glue_on binds (tc_grhss grhss)
182 = mapAndUnzipTc tc_grhs grhss `thenTc` \ (grhss', lies) ->
183 returnTc (GRHSs grhss' EmptyBinds (Just expected_ty), plusLIEs lies)
185 tc_grhs (GRHS guarded locn)
187 tcStmts ctxt (\ty -> ty, expected_ty) guarded `thenTc` \ (guarded', lie) ->
188 returnTc (GRHS guarded' locn, lie)
192 %************************************************************************
194 \subsection{tcMatchPats}
196 %************************************************************************
200 :: [RenamedPat] -> TcType
201 -> ([TypecheckedPat] -> TcType -> TcM (a, LIE))
202 -> TcM (a, LIE, TcDictBinds)
203 -- Typecheck the patterns, extend the environment to bind the variables,
204 -- do the thing inside, use any existentially-bound dictionaries to
205 -- discharge parts of the returning LIE, and deal with pattern type
208 tcMatchPats pats expected_ty thing_inside
209 = -- STEP 1: Bring pattern-signature type variables into scope
210 tcAddScopedTyVars (collectSigTysFromPats pats) $
212 -- STEP 2: Typecheck the patterns themselves, gathering all the stuff
213 tc_match_pats pats expected_ty `thenTc` \ (rhs_ty, pats', lie_req1, ex_tvs, pat_bndrs, lie_avail) ->
215 -- STEP 3: Extend the environment, and do the thing inside
217 xve = bagToList pat_bndrs
218 pat_ids = map snd xve
220 tcExtendLocalValEnv xve (thing_inside pats' rhs_ty) `thenTc` \ (result, lie_req2) ->
222 -- STEP 4: Check for existentially bound type variables
223 -- I'm a bit concerned that lie_req1 from an 'inner' pattern in the list
224 -- might need (via lie_req2) something made available from an 'outer'
225 -- pattern. But it's inconvenient to deal with, and I can't find an example
226 tcCheckExistentialPat pat_ids ex_tvs lie_avail lie_req2 rhs_ty `thenTc` \ (lie_req2', ex_binds) ->
228 returnTc (result, lie_req1 `plusLIE` lie_req2', ex_binds)
230 tcAddScopedTyVars :: [RenamedHsType] -> TcM a -> TcM a
231 -- Find the not-already-in-scope signature type variables,
232 -- kind-check them, and bring them into scope
234 -- We no longer specify that these type variables must be univerally
235 -- quantified (lots of email on the subject). If you want to put that
236 -- back in, you need to
237 -- a) Do a checkSigTyVars after thing_inside
238 -- b) More insidiously, don't pass in expected_ty, else
239 -- we unify with it too early and checkSigTyVars barfs
240 -- Instead you have to pass in a fresh ty var, and unify
241 -- it with expected_ty afterwards
242 tcAddScopedTyVars sig_tys thing_inside
243 = tcGetEnv `thenNF_Tc` \ env ->
245 all_sig_tvs = foldr (unionNameSets . extractHsTyVars) emptyNameSet sig_tys
246 sig_tvs = filter not_in_scope (nameSetToList all_sig_tvs)
247 not_in_scope tv = not (tcInLocalScope env tv)
249 tcScopedTyVars sig_tvs (kcHsSigTypes sig_tys) thing_inside
251 tcCheckExistentialPat :: [TcId] -- Ids bound by this pattern
252 -> Bag TcTyVar -- Existentially quantified tyvars bound by pattern
253 -> LIE -- and context
254 -> LIE -- Required context
255 -> TcType -- and result type; vars in here must not escape
256 -> TcM (LIE, TcDictBinds) -- LIE to float out and dict bindings
257 tcCheckExistentialPat ids ex_tvs lie_avail lie_req result_ty
258 | isEmptyBag ex_tvs && all not_overloaded ids
259 -- Short cut for case when there are no existentials
260 -- and no polymorphic overloaded variables
261 -- e.g. f :: (forall a. Ord a => a -> a) -> Int -> Int
263 -- Here we must discharge op Methods
264 = ASSERT( isEmptyLIE lie_avail )
265 returnTc (lie_req, EmptyMonoBinds)
268 = tcExtendGlobalTyVars (tyVarsOfType result_ty) $
269 tcAddErrCtxtM (sigPatCtxt tv_list ids) $
271 -- In case there are any polymorpic, overloaded binders in the pattern
272 -- (which can happen in the case of rank-2 type signatures, or data constructors
273 -- with polymorphic arguments), we must do a bindInstsOfLocalFns here
274 bindInstsOfLocalFuns lie_req ids `thenTc` \ (lie1, inst_binds) ->
276 -- Deal with overloaded functions bound by the pattern
277 tcSimplifyCheck doc tv_list
278 (lieToList lie_avail) lie1 `thenTc` \ (lie2, dict_binds) ->
279 checkSigTyVars tv_list emptyVarSet `thenTc_`
281 returnTc (lie2, dict_binds `AndMonoBinds` inst_binds)
283 doc = text ("the existential context of a data constructor")
284 tv_list = bagToList ex_tvs
285 not_overloaded id = not (isOverloadedTy (idType id))
287 tc_match_pats [] expected_ty
288 = returnTc (expected_ty, [], emptyLIE, emptyBag, emptyBag, emptyLIE)
290 tc_match_pats (pat:pats) expected_ty
291 = unifyFunTy expected_ty `thenTc` \ (arg_ty, rest_ty) ->
292 tcPat tcMonoPatBndr pat arg_ty `thenTc` \ (pat', lie_req, pat_tvs, pat_ids, lie_avail) ->
293 tc_match_pats pats rest_ty `thenTc` \ (rhs_ty, pats', lie_reqs, pats_tvs, pats_ids, lie_avails) ->
296 lie_req `plusLIE` lie_reqs,
297 pat_tvs `unionBags` pats_tvs,
298 pat_ids `unionBags` pats_ids,
299 lie_avail `plusLIE` lie_avails
304 %************************************************************************
308 %************************************************************************
310 Typechecking statements is rendered a bit tricky by parallel list comprehensions:
312 [ (g x, h x) | ... ; let g v = ...
313 | ... ; let h v = ... ]
315 It's possible that g,h are overloaded, so we need to feed the LIE from the
316 (g x, h x) up through both lots of bindings (so we get the bindInstsOfLocalFuns).
317 Similarly if we had an existential pattern match:
319 data T = forall a. Show a => C a
321 [ (show x, show y) | ... ; C x <- ...
324 Then we need the LIE from (show x, show y) to be simplified against
325 the bindings for x and y.
327 It's difficult to do this in parallel, so we rely on the renamer to
328 ensure that g,h and x,y don't duplicate, and simply grow the environment.
329 So the binders of the first parallel group will be in scope in the second
330 group. But that's fine; there's no shadowing to worry about.
333 tcStmts do_or_lc m_ty stmts
334 = tcStmtsAndThen (:) do_or_lc m_ty stmts (returnTc ([], emptyLIE))
337 :: (TcStmt -> thing -> thing) -- Combiner
338 -> RenamedMatchContext
339 -> (TcType -> TcType, TcType) -- m, the relationship type of pat and rhs in pat <- rhs
340 -- elt_ty, where type of the comprehension is (m elt_ty)
346 tcStmtsAndThen combine do_or_lc m_ty [] do_next
349 tcStmtsAndThen combine do_or_lc m_ty (stmt:stmts) do_next
350 = tcStmtAndThen combine do_or_lc m_ty stmt
351 (tcStmtsAndThen combine do_or_lc m_ty stmts do_next)
354 tcStmtAndThen combine do_or_lc m_ty (LetStmt binds) thing_inside
355 = tcBindsAndThen -- No error context, but a binding group is
356 (glue_binds combine) -- rather a large thing for an error context anyway
360 tcStmtAndThen combine do_or_lc m_ty@(m,elt_ty) stmt@(BindStmt pat exp src_loc) thing_inside
361 = tcAddSrcLoc src_loc $
362 tcAddErrCtxt (stmtCtxt do_or_lc stmt) $
363 newTyVarTy liftedTypeKind `thenNF_Tc` \ pat_ty ->
364 tcExpr exp (m pat_ty) `thenTc` \ (exp', exp_lie) ->
365 tcMatchPats [pat] (mkFunTy pat_ty (m elt_ty)) (\ [pat'] _ ->
367 thing_inside `thenTc` \ (thing, lie) ->
368 returnTc ((BindStmt pat' exp' src_loc, thing), lie)
369 ) `thenTc` \ ((stmt', thing), lie, dict_binds) ->
370 returnTc (combine stmt' (glue_binds combine Recursive dict_binds thing),
371 lie `plusLIE` exp_lie)
375 tcStmtAndThen combine do_or_lc m_ty (ParStmtOut bndr_stmts_s) thing_inside
376 = loop bndr_stmts_s `thenTc` \ ((pairs', thing), lie) ->
377 returnTc (combine (ParStmtOut pairs') thing, lie)
380 = thing_inside `thenTc` \ (thing, stmts_lie) ->
381 returnTc (([], thing), stmts_lie)
383 loop ((bndrs,stmts) : pairs)
385 combine_par (DoCtxt ListComp) m_ty stmts
386 -- Notice we pass on m_ty; the result type is used only
387 -- to get escaping type variables for checkExistentialPat
388 (tcLookupLocalIds bndrs `thenNF_Tc` \ bndrs' ->
389 loop pairs `thenTc` \ ((pairs', thing), lie) ->
390 returnTc (([], (bndrs', pairs', thing)), lie)) `thenTc` \ ((stmts', (bndrs', pairs', thing)), lie) ->
392 returnTc ( ((bndrs',stmts') : pairs', thing), lie)
394 combine_par stmt (stmts, thing) = (stmt:stmts, thing)
397 tcStmtAndThen combine do_or_lc m_ty@(m, res_elt_ty) stmt@(ExprStmt exp locn) thing_inside
398 = tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
399 if isDoExpr do_or_lc then
400 newTyVarTy openTypeKind `thenNF_Tc` \ any_ty ->
401 tcExpr exp (m any_ty)
404 ) `thenTc` \ (exp', stmt_lie) ->
406 thing_inside `thenTc` \ (thing, stmts_lie) ->
408 returnTc (combine (ExprStmt exp' locn) thing,
409 stmt_lie `plusLIE` stmts_lie)
413 tcStmtAndThen combine do_or_lc m_ty@(m, res_elt_ty) stmt@(ResultStmt exp locn) thing_inside
414 = tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
415 if isDoExpr do_or_lc then
416 tcExpr exp (m res_elt_ty)
418 tcExpr exp res_elt_ty
419 ) `thenTc` \ (exp', stmt_lie) ->
421 thing_inside `thenTc` \ (thing, stmts_lie) ->
423 returnTc (combine (ResultStmt exp' locn) thing,
424 stmt_lie `plusLIE` stmts_lie)
427 ------------------------------
428 glue_binds combine is_rec binds thing
429 | nullMonoBinds binds = thing
430 | otherwise = combine (LetStmt (mkMonoBind binds [] is_rec)) thing
434 %************************************************************************
436 \subsection{Errors and contexts}
438 %************************************************************************
440 @sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same
441 number of args are used in each equation.
444 sameNoOfArgs :: [RenamedMatch] -> Bool
445 sameNoOfArgs matches = length (nub (map args_in_match matches)) == 1
447 args_in_match :: RenamedMatch -> Int
448 args_in_match (Match _ pats _ _) = length pats
452 matchCtxt ctxt match = hang (pprMatchContext ctxt <> colon) 4 (pprMatch ctxt match)
453 stmtCtxt do_or_lc stmt = hang (pprMatchContext do_or_lc <> colon) 4 (ppr stmt)
455 varyingArgsErr name matches
456 = sep [ptext SLIT("Varying number of arguments for function"), quotes (ppr name)]
459 = ptext SLIT("Too few explicit arguments when defining a function with a rank-2 type")