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,
16 mkMonoBind, collectSigTysFromPats
18 import RnHsSyn ( RenamedMatch, RenamedGRHSs, RenamedStmt )
19 import TcHsSyn ( TcMatch, TcGRHSs, TcStmt )
22 import TcMonoType ( kcHsSigType, kcTyVarScope, checkSigTyVars, tcHsTyVar, tcHsSigType, sigPatCtxt )
23 import Inst ( Inst, LIE, plusLIE, emptyLIE, plusLIEs )
24 import TcEnv ( tcExtendTyVarEnv, tcExtendLocalValEnv, tcExtendGlobalTyVars, tcGetGlobalTyVars )
25 import TcPat ( tcPat, tcPatBndr_NoSigs, polyPatSig )
26 import TcType ( TcType, newTyVarTy )
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, openTypeKind )
42 %************************************************************************
44 \subsection{tcMatchesFun, tcMatchesCase}
46 %************************************************************************
48 @tcMatchesFun@ typechecks a @[Match]@ list which occurs in a
49 @FunMonoBind@. The second argument is the name of the function, which
50 is used in error messages. It checks that all the equations have the
51 same number of arguments before using @tcMatches@ to do the work.
54 tcMatchesFun :: [(Name,Id)] -- Bindings for the variables bound in this group
56 -> TcType -- Expected type
58 -> TcM s ([TcMatch], LIE)
60 tcMatchesFun xve fun_name expected_ty matches@(first_match:_)
61 = -- Check that they all have the same no of arguments
62 -- Set the location to that of the first equation, so that
63 -- any inter-equation error messages get some vaguely
64 -- sensible location. Note: we have to do this odd
65 -- ann-grabbing, because we don't always have annotations in
66 -- hand when we call tcMatchesFun...
67 tcAddSrcLoc (getMatchLoc first_match) (
68 checkTc (sameNoOfArgs matches)
69 (varyingArgsErr fun_name matches)
72 -- ToDo: Don't use "expected" stuff if there ain't a type signature
73 -- because inconsistency between branches
74 -- may show up as something wrong with the (non-existent) type signature
76 -- No need to zonk expected_ty, because unifyFunTy does that on the fly
77 tcMatches xve matches expected_ty (FunRhs fun_name)
80 @tcMatchesCase@ doesn't do the argument-count check because the
81 parser guarantees that each equation has exactly one argument.
84 tcMatchesCase :: [RenamedMatch] -- The case alternatives
85 -> TcType -- Type of whole case expressions
86 -> TcM s (TcType, -- Inferred type of the scrutinee
87 [TcMatch], -- Translated alternatives
90 tcMatchesCase matches expr_ty
91 = newTyVarTy openTypeKind `thenNF_Tc` \ scrut_ty ->
92 tcMatches [] matches (mkFunTy scrut_ty expr_ty) CaseAlt `thenTc` \ (matches', lie) ->
93 returnTc (scrut_ty, matches', lie)
95 tcMatchLambda :: RenamedMatch -> TcType -> TcM s (TcMatch, LIE)
96 tcMatchLambda match res_ty = tcMatch [] match res_ty LambdaBody
101 tcMatches :: [(Name,Id)]
105 -> TcM s ([TcMatch], LIE)
107 tcMatches xve matches expected_ty fun_or_case
108 = mapAndUnzipTc tc_match matches `thenTc` \ (matches, lies) ->
109 returnTc (matches, plusLIEs lies)
111 tc_match match = tcMatch xve match expected_ty fun_or_case
115 %************************************************************************
119 %************************************************************************
122 tcMatch :: [(Name,Id)]
124 -> TcType -- Expected result-type of the Match.
125 -- Early unification with this guy gives better error messages
127 -> TcM s (TcMatch, LIE)
129 tcMatch xve1 match@(Match sig_tvs pats maybe_rhs_sig grhss) expected_ty ctxt
130 = tcAddSrcLoc (getMatchLoc match) $
131 tcAddErrCtxt (matchCtxt ctxt match) $
133 if null sig_tvs then -- The common case
134 tc_match expected_ty `thenTc` \ (_, match_and_lie) ->
135 returnTc match_and_lie
138 -- If there are sig tvs we must be careful *not* to use
139 -- expected_ty right away, else we'll unify with tyvars free
140 -- in the envt. So invent a fresh tyvar and use that instead
141 newTyVarTy openTypeKind `thenNF_Tc` \ tyvar_ty ->
143 -- Extend the tyvar env and check the match itself
144 kcTyVarScope sig_tvs (mapTc_ kcHsSigType sig_tys) `thenTc` \ sig_tyvars ->
145 tcExtendTyVarEnv sig_tyvars (
147 ) `thenTc` \ (pat_ids, match_and_lie) ->
149 -- Check that the scoped type variables from the patterns
150 -- have not been constrained
151 tcAddErrCtxtM (sigPatCtxt sig_tyvars pat_ids) (
152 checkSigTyVars sig_tyvars emptyVarSet
155 -- *Now* we're free to unify with expected_ty
156 unifyTauTy expected_ty tyvar_ty `thenTc_`
158 returnTc match_and_lie
161 sig_tys = case maybe_rhs_sig of { Just t -> [t]; Nothing -> [] }
162 ++ collectSigTysFromPats pats
164 tc_match expected_ty -- Any sig tyvars are in scope by now
165 = -- STEP 1: Typecheck the patterns
166 tcMatchPats pats expected_ty `thenTc` \ (rhs_ty, pats', lie_req1, ex_tvs, pat_bndrs, lie_avail) ->
168 xve2 = bagToList pat_bndrs
169 pat_ids = map snd xve2
170 ex_tv_list = bagToList ex_tvs
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 tcExtendGlobalTyVars (tyVarsOfType rhs_ty) (
195 tcAddErrCtxtM (sigPatCtxt ex_tv_list pat_ids) $
196 checkSigTyVars ex_tv_list emptyVarSet `thenTc` \ zonked_ex_tvs ->
198 (text ("the existential context of a data constructor"))
199 (mkVarSet zonked_ex_tvs)
200 lie_avail (lie_req1 `plusLIE` lie_req2)
201 ) `thenTc` \ (lie_req', ex_binds) ->
203 -- STEP 6 In case there are any polymorpic, overloaded binders in the pattern
204 -- (which can happen in the case of rank-2 type signatures, or data constructors
205 -- with polymorphic arguments), we must do a bindInstsOfLocalFns here
206 bindInstsOfLocalFuns lie_req' pat_ids `thenTc` \ (lie_req'', inst_binds) ->
210 grhss'' = glue_on Recursive ex_binds $
211 glue_on Recursive inst_binds grhss'
213 returnTc (pat_ids, (Match [] pats' Nothing grhss'', lie_req''))
215 -- glue_on just avoids stupid dross
216 glue_on _ EmptyMonoBinds grhss = grhss -- The common case
217 glue_on is_rec mbinds (GRHSs grhss binds ty)
218 = GRHSs grhss (mkMonoBind mbinds [] is_rec `ThenBinds` binds) ty
220 tcGRHSs :: RenamedGRHSs
221 -> TcType -> StmtCtxt
222 -> TcM s (TcGRHSs, LIE)
224 tcGRHSs (GRHSs grhss binds _) expected_ty ctxt
225 = tcBindsAndThen glue_on binds (tc_grhss grhss)
228 = mapAndUnzipTc tc_grhs grhss `thenTc` \ (grhss', lies) ->
229 returnTc (GRHSs grhss' EmptyBinds (Just expected_ty), plusLIEs lies)
231 tc_grhs (GRHS guarded locn)
233 tcStmts ctxt (\ty -> ty) guarded expected_ty `thenTc` \ (guarded', lie) ->
234 returnTc (GRHS guarded' locn, lie)
238 %************************************************************************
240 \subsection{tcMatchPats}
242 %************************************************************************
245 tcMatchPats [] expected_ty
246 = returnTc (expected_ty, [], emptyLIE, emptyBag, emptyBag, emptyLIE)
248 tcMatchPats (pat:pats) expected_ty
249 = unifyFunTy expected_ty `thenTc` \ (arg_ty, rest_ty) ->
250 tcPat tcPatBndr_NoSigs pat arg_ty `thenTc` \ (pat', lie_req, pat_tvs, pat_ids, lie_avail) ->
251 tcMatchPats pats rest_ty `thenTc` \ (rhs_ty, pats', lie_reqs, pats_tvs, pats_ids, lie_avails) ->
254 lie_req `plusLIE` lie_reqs,
255 pat_tvs `unionBags` pats_tvs,
256 pat_ids `unionBags` pats_ids,
257 lie_avail `plusLIE` lie_avails
262 %************************************************************************
266 %************************************************************************
271 -> (TcType -> TcType) -- m, the relationship type of pat and rhs in pat <- rhs
273 -> TcType -- elt_ty, where type of the comprehension is (m elt_ty)
274 -> TcM s ([TcStmt], LIE)
276 tcStmts do_or_lc m (stmt@(ReturnStmt exp) : stmts) elt_ty
277 = ASSERT( null stmts )
278 tcSetErrCtxt (stmtCtxt do_or_lc stmt) $
279 tcExpr exp elt_ty `thenTc` \ (exp', exp_lie) ->
280 returnTc ([ReturnStmt exp'], exp_lie)
282 -- ExprStmt at the end
283 tcStmts do_or_lc m [stmt@(ExprStmt exp src_loc)] elt_ty
284 = tcSetErrCtxt (stmtCtxt do_or_lc stmt) $
285 tcExpr exp (m elt_ty) `thenTc` \ (exp', exp_lie) ->
286 returnTc ([ExprStmt exp' src_loc], exp_lie)
288 -- ExprStmt not at the end
289 tcStmts do_or_lc m (stmt@(ExprStmt exp src_loc) : stmts) elt_ty
290 = ASSERT( isDoStmt do_or_lc )
291 tcAddSrcLoc src_loc (
292 tcSetErrCtxt (stmtCtxt do_or_lc stmt) $
293 -- exp has type (m tau) for some tau (doesn't matter what)
294 newTyVarTy openTypeKind `thenNF_Tc` \ any_ty ->
295 tcExpr exp (m any_ty)
296 ) `thenTc` \ (exp', exp_lie) ->
297 tcStmts do_or_lc m stmts elt_ty `thenTc` \ (stmts', stmts_lie) ->
298 returnTc (ExprStmt exp' src_loc : stmts',
299 exp_lie `plusLIE` stmts_lie)
301 tcStmts do_or_lc m (stmt@(GuardStmt exp src_loc) : stmts) elt_ty
302 = ASSERT( not (isDoStmt do_or_lc) )
303 tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
304 tcAddSrcLoc src_loc $
306 ) `thenTc` \ (exp', exp_lie) ->
307 tcStmts do_or_lc m stmts elt_ty `thenTc` \ (stmts', stmts_lie) ->
308 returnTc (GuardStmt exp' src_loc : stmts',
309 exp_lie `plusLIE` stmts_lie)
311 tcStmts do_or_lc m (stmt@(BindStmt pat exp src_loc) : stmts) elt_ty
312 = tcAddSrcLoc src_loc (
313 tcSetErrCtxt (stmtCtxt do_or_lc stmt) $
314 newTyVarTy boxedTypeKind `thenNF_Tc` \ pat_ty ->
315 tcPat tcPatBndr_NoSigs pat pat_ty `thenTc` \ (pat', pat_lie, pat_tvs, pat_ids, avail) ->
316 tcExpr exp (m pat_ty) `thenTc` \ (exp', exp_lie) ->
317 returnTc (pat', exp',
318 pat_lie `plusLIE` exp_lie,
319 pat_tvs, pat_ids, avail)
320 ) `thenTc` \ (pat', exp', lie_req, pat_tvs, pat_bndrs, lie_avail) ->
322 new_val_env = bagToList pat_bndrs
323 pat_ids = map snd new_val_env
324 pat_tv_list = bagToList pat_tvs
327 -- Do the rest; we don't need to add the pat_tvs to the envt
328 -- because they all appear in the pat_ids's types
329 tcExtendLocalValEnv new_val_env (
330 tcStmts do_or_lc m stmts elt_ty
331 ) `thenTc` \ (stmts', stmts_lie) ->
334 -- Reinstate context for existential checks
335 tcSetErrCtxt (stmtCtxt do_or_lc stmt) $
336 tcExtendGlobalTyVars (tyVarsOfType (m elt_ty)) $
337 tcAddErrCtxtM (sigPatCtxt pat_tv_list pat_ids) $
339 checkSigTyVars pat_tv_list emptyVarSet `thenTc` \ zonked_pat_tvs ->
342 (text ("the existential context of a data constructor"))
343 (mkVarSet zonked_pat_tvs)
344 lie_avail stmts_lie `thenTc` \ (final_lie, dict_binds) ->
346 returnTc (BindStmt pat' exp' src_loc :
347 consLetStmt (mkMonoBind dict_binds [] Recursive) stmts',
348 lie_req `plusLIE` final_lie)
350 tcStmts do_or_lc m (LetStmt binds : stmts) elt_ty
351 = tcBindsAndThen -- No error context, but a binding group is
352 combine -- rather a large thing for an error context anyway
354 (tcStmts do_or_lc m stmts elt_ty)
356 combine is_rec binds' stmts' = consLetStmt (mkMonoBind binds' [] is_rec) stmts'
359 isDoStmt DoStmt = True
360 isDoStmt other = False
364 %************************************************************************
366 \subsection{Errors and contexts}
368 %************************************************************************
370 @sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same
371 number of args are used in each equation.
374 sameNoOfArgs :: [RenamedMatch] -> Bool
375 sameNoOfArgs matches = length (nub (map args_in_match matches)) == 1
377 args_in_match :: RenamedMatch -> Int
378 args_in_match (Match _ pats _ _) = length pats
382 matchCtxt CaseAlt match
383 = hang (ptext SLIT("In a case alternative:"))
384 4 (pprMatch (True,empty) {-is_case-} match)
386 matchCtxt (FunRhs fun) match
387 = hang (hcat [ptext SLIT("In an equation for function "), quotes (ppr_fun), char ':'])
388 4 (pprMatch (False, ppr_fun) {-not case-} match)
392 matchCtxt LambdaBody match
393 = hang (ptext SLIT("In the lambda expression"))
394 4 (pprMatch (True, empty) match)
396 varyingArgsErr name matches
397 = sep [ptext SLIT("Varying number of arguments for function"), quotes (ppr name)]
400 = ptext SLIT("Too few explicit arguments when defining a function with a rank-2 type")
402 stmtCtxt do_or_lc stmt
403 = hang (ptext SLIT("In") <+> what <> colon)
406 what = case do_or_lc of
407 ListComp -> ptext SLIT("a list-comprehension qualifier")
408 DoStmt -> ptext SLIT("a do statement")
409 PatBindRhs -> thing <+> ptext SLIT("a pattern binding")
410 FunRhs f -> thing <+> ptext SLIT("an equation for") <+> quotes (ppr f)
411 CaseAlt -> thing <+> ptext SLIT("a case alternative")
412 LambdaBody -> thing <+> ptext SLIT("a lambda abstraction")
414 BindStmt _ _ _ -> ptext SLIT("a pattern guard for")
415 GuardStmt _ _ -> ptext SLIT("a guard for")
416 ExprStmt _ _ -> ptext SLIT("the right-hand side of")