2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[TcMatches]{Typecheck some @Matches@}
7 module TcMatches ( tcMatchesFun, tcMatchesCase, tcMatchLambda, tcStmts, tcGRHSs ) where
9 #include "HsVersions.h"
11 import {-# SOURCE #-} TcExpr( tcExpr )
13 import HsSyn ( HsBinds(..), Match(..), GRHSs(..), GRHS(..),
14 MonoBinds(..), StmtCtxt(..), Stmt(..),
15 pprMatch, getMatchLoc, consLetStmt,
18 import RnHsSyn ( RenamedMatch, RenamedGRHSs, RenamedStmt )
19 import TcHsSyn ( TcMatch, TcGRHSs, TcStmt )
22 import TcMonoType ( checkSigTyVars, tcHsTyVar, tcHsSigType, sigPatCtxt )
23 import Inst ( Inst, LIE, plusLIE, emptyLIE, plusLIEs )
24 import TcEnv ( tcExtendLocalValEnv, tcExtendGlobalTyVars, tcExtendTyVarEnv, tcGetGlobalTyVars )
25 import TcPat ( tcPat, tcPatBndr_NoSigs, polyPatSig )
26 import TcType ( TcType, newTyVarTy, newTyVarTy_OpenKind, zonkTcTyVars )
27 import TcBinds ( tcBindsAndThen )
28 import TcSimplify ( tcSimplifyAndCheck, bindInstsOfLocalFuns )
29 import TcUnify ( unifyFunTy, unifyTauTy )
31 import TysWiredIn ( boolTy )
33 import BasicTypes ( RecFlag(..) )
34 import Type ( Kind, tyVarsOfType, isTauTy, mkFunTy, boxedTypeKind )
43 %************************************************************************
45 \subsection{tcMatchesFun, tcMatchesCase}
47 %************************************************************************
49 @tcMatchesFun@ typechecks a @[Match]@ list which occurs in a
50 @FunMonoBind@. The second argument is the name of the function, which
51 is used in error messages. It checks that all the equations have the
52 same number of arguments before using @tcMatches@ to do the work.
55 tcMatchesFun :: [(Name,Id)] -- Bindings for the variables bound in this group
57 -> TcType -- Expected type
59 -> TcM s ([TcMatch], LIE)
61 tcMatchesFun xve fun_name expected_ty matches@(first_match:_)
62 = -- Check that they all have the same no of arguments
63 -- Set the location to that of the first equation, so that
64 -- any inter-equation error messages get some vaguely
65 -- sensible location. Note: we have to do this odd
66 -- ann-grabbing, because we don't always have annotations in
67 -- hand when we call tcMatchesFun...
68 tcAddSrcLoc (getMatchLoc first_match) (
69 checkTc (sameNoOfArgs matches)
70 (varyingArgsErr fun_name matches)
73 -- ToDo: Don't use "expected" stuff if there ain't a type signature
74 -- because inconsistency between branches
75 -- may show up as something wrong with the (non-existent) type signature
77 -- No need to zonk expected_ty, because unifyFunTy does that on the fly
78 tcMatches xve matches expected_ty (FunRhs fun_name)
81 @tcMatchesCase@ doesn't do the argument-count check because the
82 parser guarantees that each equation has exactly one argument.
85 tcMatchesCase :: [RenamedMatch] -- The case alternatives
86 -> TcType -- Type of whole case expressions
87 -> TcM s (TcType, -- Inferred type of the scrutinee
88 [TcMatch], -- Translated alternatives
91 tcMatchesCase matches expr_ty
92 = newTyVarTy_OpenKind `thenNF_Tc` \ scrut_ty ->
93 tcMatches [] matches (mkFunTy scrut_ty expr_ty) CaseAlt `thenTc` \ (matches', lie) ->
94 returnTc (scrut_ty, matches', lie)
96 tcMatchLambda :: RenamedMatch -> TcType -> TcM s (TcMatch, LIE)
97 tcMatchLambda match res_ty = tcMatch [] match res_ty LambdaBody
102 tcMatches :: [(Name,Id)]
106 -> TcM s ([TcMatch], LIE)
108 tcMatches xve matches expected_ty fun_or_case
109 = mapAndUnzipTc tc_match matches `thenTc` \ (matches, lies) ->
110 returnTc (matches, plusLIEs lies)
112 tc_match match = tcMatch xve match expected_ty fun_or_case
116 %************************************************************************
120 %************************************************************************
123 tcMatch :: [(Name,Id)]
125 -> TcType -- Expected result-type of the Match.
126 -- Early unification with this guy gives better error messages
128 -> TcM s (TcMatch, LIE)
130 tcMatch xve1 match@(Match sig_tvs pats maybe_rhs_sig grhss) expected_ty ctxt
131 = tcAddSrcLoc (getMatchLoc match) $
132 tcAddErrCtxt (matchCtxt ctxt match) $
134 if null sig_tvs then -- The common case
135 tc_match expected_ty `thenTc` \ (_, match_and_lie) ->
136 returnTc match_and_lie
139 -- If there are sig tvs we must be careful *not* to use
140 -- expected_ty right away, else we'll unify with tyvars free
141 -- in the envt. So invent a fresh tyvar and use that instead
142 newTyVarTy_OpenKind `thenNF_Tc` \ tyvar_ty ->
144 -- Extend the tyvar env and check the match itself
145 mapNF_Tc tcHsTyVar sig_tvs `thenNF_Tc` \ sig_tyvars ->
146 tcExtendTyVarEnv sig_tyvars (
148 ) `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 tc_match expected_ty -- Any sig tyvars are in scope by now
163 = -- STEP 1: Typecheck the patterns
164 tcMatchPats pats expected_ty `thenTc` \ (rhs_ty, pats', lie_req1, ex_tvs, pat_bndrs, lie_avail) ->
166 xve2 = bagToList pat_bndrs
167 pat_ids = map snd xve2
168 ex_tv_list = bagToList ex_tvs
171 -- STEP 2: Check that the remaining "expected type" is not a rank-2 type
172 -- If it is it'll mess up the unifier when checking the RHS
173 checkTc (isTauTy rhs_ty) lurkingRank2SigErr `thenTc_`
175 -- STEP 3: Unify with the rhs type signature if any
176 (case maybe_rhs_sig of
177 Nothing -> returnTc ()
178 Just sig -> tcHsSigType sig `thenTc` \ sig_ty ->
180 -- Check that the signature isn't a polymorphic one, which
181 -- we don't permit (at present, anyway)
182 checkTc (isTauTy sig_ty) (polyPatSig sig_ty) `thenTc_`
183 unifyTauTy rhs_ty sig_ty
186 -- STEP 4: Typecheck the guarded RHSs and the associated where clause
187 tcExtendLocalValEnv xve1 (tcExtendLocalValEnv xve2 (
188 tcGRHSs grhss rhs_ty ctxt
189 )) `thenTc` \ (grhss', lie_req2) ->
191 -- STEP 5: Check for existentially bound type variables
192 tcExtendGlobalTyVars (tyVarsOfType rhs_ty) (
193 tcAddErrCtxtM (sigPatCtxt ex_tv_list pat_ids) $
194 checkSigTyVars ex_tv_list emptyVarSet `thenTc` \ zonked_ex_tvs ->
196 (text ("the existential context of a data constructor"))
197 (mkVarSet zonked_ex_tvs)
198 lie_avail (lie_req1 `plusLIE` lie_req2)
199 ) `thenTc` \ (lie_req', ex_binds) ->
201 -- STEP 6 In case there are any polymorpic, overloaded binders in the pattern
202 -- (which can happen in the case of rank-2 type signatures, or data constructors
203 -- with polymorphic arguments), we must do a bindInstsOfLocalFns here
204 bindInstsOfLocalFuns lie_req' pat_ids `thenTc` \ (lie_req'', inst_binds) ->
208 grhss'' = glue_on Recursive ex_binds $
209 glue_on Recursive inst_binds grhss'
211 returnTc (pat_ids, (Match [] pats' Nothing grhss'', lie_req''))
213 -- glue_on just avoids stupid dross
214 glue_on _ EmptyMonoBinds grhss = grhss -- The common case
215 glue_on is_rec mbinds (GRHSs grhss binds ty)
216 = GRHSs grhss (mkMonoBind mbinds [] is_rec `ThenBinds` binds) ty
218 tcGRHSs :: RenamedGRHSs
219 -> TcType -> StmtCtxt
220 -> TcM s (TcGRHSs, LIE)
222 tcGRHSs (GRHSs grhss binds _) expected_ty ctxt
223 = tcBindsAndThen glue_on binds (tc_grhss grhss)
226 = mapAndUnzipTc tc_grhs grhss `thenTc` \ (grhss', lies) ->
227 returnTc (GRHSs grhss' EmptyBinds (Just expected_ty), plusLIEs lies)
229 tc_grhs (GRHS guarded locn)
231 tcStmts ctxt (\ty -> ty) guarded expected_ty `thenTc` \ (guarded', lie) ->
232 returnTc (GRHS guarded' locn, lie)
236 %************************************************************************
238 \subsection{tcMatchPats}
240 %************************************************************************
243 tcMatchPats [] expected_ty
244 = returnTc (expected_ty, [], emptyLIE, emptyBag, emptyBag, emptyLIE)
246 tcMatchPats (pat:pats) expected_ty
247 = unifyFunTy expected_ty `thenTc` \ (arg_ty, rest_ty) ->
248 tcPat tcPatBndr_NoSigs pat arg_ty `thenTc` \ (pat', lie_req, pat_tvs, pat_ids, lie_avail) ->
249 tcMatchPats pats rest_ty `thenTc` \ (rhs_ty, pats', lie_reqs, pats_tvs, pats_ids, lie_avails) ->
252 lie_req `plusLIE` lie_reqs,
253 pat_tvs `unionBags` pats_tvs,
254 pat_ids `unionBags` pats_ids,
255 lie_avail `plusLIE` lie_avails
260 %************************************************************************
264 %************************************************************************
269 -> (TcType -> TcType) -- m, the relationship type of pat and rhs in pat <- rhs
271 -> TcType -- elt_ty, where type of the comprehension is (m elt_ty)
272 -> TcM s ([TcStmt], LIE)
274 tcStmts do_or_lc m (stmt@(ReturnStmt exp) : stmts) elt_ty
275 = ASSERT( null stmts )
276 tcSetErrCtxt (stmtCtxt do_or_lc stmt) $
277 tcExpr exp elt_ty `thenTc` \ (exp', exp_lie) ->
278 returnTc ([ReturnStmt exp'], exp_lie)
280 -- ExprStmt at the end
281 tcStmts do_or_lc m [stmt@(ExprStmt exp src_loc)] elt_ty
282 = tcSetErrCtxt (stmtCtxt do_or_lc stmt) $
283 tcExpr exp (m elt_ty) `thenTc` \ (exp', exp_lie) ->
284 returnTc ([ExprStmt exp' src_loc], exp_lie)
286 -- ExprStmt not at the end
287 tcStmts do_or_lc m (stmt@(ExprStmt exp src_loc) : stmts) elt_ty
288 = ASSERT( isDoStmt do_or_lc )
289 tcAddSrcLoc src_loc (
290 tcSetErrCtxt (stmtCtxt do_or_lc stmt) $
291 -- exp has type (m tau) for some tau (doesn't matter what)
292 newTyVarTy_OpenKind `thenNF_Tc` \ any_ty ->
293 tcExpr exp (m any_ty)
294 ) `thenTc` \ (exp', exp_lie) ->
295 tcStmts do_or_lc m stmts elt_ty `thenTc` \ (stmts', stmts_lie) ->
296 returnTc (ExprStmt exp' src_loc : stmts',
297 exp_lie `plusLIE` stmts_lie)
299 tcStmts do_or_lc m (stmt@(GuardStmt exp src_loc) : stmts) elt_ty
300 = ASSERT( not (isDoStmt do_or_lc) )
301 tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
302 tcAddSrcLoc src_loc $
304 ) `thenTc` \ (exp', exp_lie) ->
305 tcStmts do_or_lc m stmts elt_ty `thenTc` \ (stmts', stmts_lie) ->
306 returnTc (GuardStmt exp' src_loc : stmts',
307 exp_lie `plusLIE` stmts_lie)
309 tcStmts do_or_lc m (stmt@(BindStmt pat exp src_loc) : stmts) elt_ty
310 = tcAddSrcLoc src_loc (
311 tcSetErrCtxt (stmtCtxt do_or_lc stmt) $
312 newTyVarTy boxedTypeKind `thenNF_Tc` \ pat_ty ->
313 tcPat tcPatBndr_NoSigs pat pat_ty `thenTc` \ (pat', pat_lie, pat_tvs, pat_ids, avail) ->
314 tcExpr exp (m pat_ty) `thenTc` \ (exp', exp_lie) ->
315 returnTc (pat', exp',
316 pat_lie `plusLIE` exp_lie,
317 pat_tvs, pat_ids, avail)
318 ) `thenTc` \ (pat', exp', lie_req, pat_tvs, pat_bndrs, lie_avail) ->
320 new_val_env = bagToList pat_bndrs
321 pat_ids = map snd new_val_env
322 pat_tv_list = bagToList pat_tvs
325 -- Do the rest; we don't need to add the pat_tvs to the envt
326 -- because they all appear in the pat_ids's types
327 tcExtendLocalValEnv new_val_env (
328 tcStmts do_or_lc m stmts elt_ty
329 ) `thenTc` \ (stmts', stmts_lie) ->
332 -- Reinstate context for existential checks
333 tcSetErrCtxt (stmtCtxt do_or_lc stmt) $
334 tcExtendGlobalTyVars (tyVarsOfType (m elt_ty)) $
335 tcAddErrCtxtM (sigPatCtxt pat_tv_list pat_ids) $
337 checkSigTyVars pat_tv_list emptyVarSet `thenTc` \ zonked_pat_tvs ->
340 (text ("the existential context of a data constructor"))
341 (mkVarSet zonked_pat_tvs)
342 lie_avail stmts_lie `thenTc` \ (final_lie, dict_binds) ->
344 returnTc (BindStmt pat' exp' src_loc :
345 consLetStmt (mkMonoBind dict_binds [] Recursive) stmts',
346 lie_req `plusLIE` final_lie)
348 tcStmts do_or_lc m (LetStmt binds : stmts) elt_ty
349 = tcBindsAndThen -- No error context, but a binding group is
350 combine -- rather a large thing for an error context anyway
352 (tcStmts do_or_lc m stmts elt_ty)
354 combine is_rec binds' stmts' = consLetStmt (mkMonoBind binds' [] is_rec) stmts'
357 isDoStmt DoStmt = True
358 isDoStmt other = False
362 %************************************************************************
364 \subsection{Errors and contexts}
366 %************************************************************************
368 @sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same
369 number of args are used in each equation.
372 sameNoOfArgs :: [RenamedMatch] -> Bool
373 sameNoOfArgs matches = length (nub (map args_in_match matches)) == 1
375 args_in_match :: RenamedMatch -> Int
376 args_in_match (Match _ pats _ _) = length pats
380 matchCtxt CaseAlt match
381 = hang (ptext SLIT("In a case alternative:"))
382 4 (pprMatch (True,empty) {-is_case-} match)
384 matchCtxt (FunRhs fun) match
385 = hang (hcat [ptext SLIT("In an equation for function "), quotes (ppr_fun), char ':'])
386 4 (pprMatch (False, ppr_fun) {-not case-} match)
390 matchCtxt LambdaBody match
391 = hang (ptext SLIT("In the lambda expression"))
392 4 (pprMatch (True, empty) match)
394 varyingArgsErr name matches
395 = sep [ptext SLIT("Varying number of arguments for function"), quotes (ppr name)]
398 = ptext SLIT("Too few explicit arguments when defining a function with a rank-2 type")
400 stmtCtxt do_or_lc stmt
401 = hang (ptext SLIT("In") <+> what <> colon)
404 what = case do_or_lc of
405 ListComp -> ptext SLIT("a list-comprehension qualifier")
406 DoStmt -> ptext SLIT("a do statement")
407 PatBindRhs -> thing <+> ptext SLIT("a pattern binding")
408 FunRhs f -> thing <+> ptext SLIT("an equation for") <+> quotes (ppr f)
409 CaseAlt -> thing <+> ptext SLIT("a case alternative")
410 LambdaBody -> thing <+> ptext SLIT("a lambda abstraction")
412 BindStmt _ _ _ -> ptext SLIT("a pattern guard for")
413 GuardStmt _ _ -> ptext SLIT("a guard for")
414 ExprStmt _ _ -> ptext SLIT("the right-hand side of")