2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[TcMatches]{Typecheck some @Matches@}
7 module TcMatches ( tcMatchesFun, tcGRHSsPat, tcMatchesCase, tcMatchLambda,
8 matchCtxt, TcMatchCtxt(..),
10 tcDoStmt, tcMDoStmt, tcGuardStmt
13 #include "HsVersions.h"
15 import {-# SOURCE #-} TcExpr( tcSyntaxOp, tcInferRho, tcMonoExpr, tcPolyExpr )
17 import HsSyn ( HsExpr(..), LHsExpr, MatchGroup(..),
18 Match(..), LMatch, GRHSs(..), GRHS(..),
19 Stmt(..), LStmt, HsMatchContext(..), HsStmtContext(..),
20 pprMatch, isIrrefutableHsPat, mkHsCoerce,
21 pprMatchContext, pprStmtContext,
22 noSyntaxExpr, matchGroupArity, pprMatches,
26 import Inst ( newMethodFromName )
27 import TcEnv ( TcId, tcLookupLocalIds, tcLookupId, tcExtendIdEnv )
28 import TcPat ( PatCtxt(..), tcPats, tcPat )
29 import TcMType ( newFlexiTyVarTy, newFlexiTyVarTys )
30 import TcType ( TcType, TcRhoType,
31 BoxySigmaType, BoxyRhoType,
32 mkFunTys, mkFunTy, mkAppTy, mkTyConApp,
34 import TcBinds ( tcLocalBinds )
35 import TcUnify ( boxySplitAppTy, boxySplitTyConApp, boxySplitListTy,
36 subFunTys, tcSubExp, withBox )
37 import TcSimplify ( bindInstsOfLocalFuns )
39 import TysWiredIn ( stringTy, boolTy, parrTyCon, listTyCon, mkListTy, mkPArrTy )
40 import PrelNames ( bindMName, returnMName, mfixName, thenMName, failMName )
41 import Id ( idType, mkLocalId )
42 import TyCon ( TyCon )
44 import SrcLoc ( Located(..), getLoc )
45 import ErrUtils ( Message )
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.
62 -> BoxyRhoType -- Expected type of function
63 -> TcM (ExprCoFn, MatchGroup TcId) -- Returns type of body
65 tcMatchesFun fun_name matches exp_ty
66 = do { -- Check that they all have the same no of arguments
67 -- Location is in the monad, set the caller 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 checkArgs fun_name matches
74 -- ToDo: Don't use "expected" stuff if there ain't a type signature
75 -- because inconsistency between branches
76 -- may show up as something wrong with the (non-existent) type signature
78 -- This is one of two places places we call subFunTys
79 -- The point is that if expected_y is a "hole", we want
80 -- to make pat_tys and rhs_ty as "holes" too.
81 ; subFunTys doc n_pats exp_ty $ \ pat_tys rhs_ty ->
82 tcMatches match_ctxt pat_tys rhs_ty matches
85 doc = ptext SLIT("The equation(s) for") <+> quotes (ppr fun_name)
86 <+> ptext SLIT("have") <+> speakNOf n_pats (ptext SLIT("argument"))
87 n_pats = matchGroupArity matches
88 match_ctxt = MC { mc_what = FunRhs fun_name, mc_body = tcPolyExpr }
91 @tcMatchesCase@ doesn't do the argument-count check because the
92 parser guarantees that each equation has exactly one argument.
95 tcMatchesCase :: TcMatchCtxt -- Case context
96 -> TcRhoType -- Type of scrutinee
97 -> MatchGroup Name -- The case alternatives
98 -> BoxyRhoType -- Type of whole case expressions
99 -> TcM (MatchGroup TcId) -- Translated alternatives
101 tcMatchesCase ctxt scrut_ty matches res_ty
102 = tcMatches ctxt [scrut_ty] res_ty matches
104 tcMatchLambda :: MatchGroup Name -> BoxyRhoType -> TcM (ExprCoFn, MatchGroup TcId)
105 tcMatchLambda match res_ty
106 = subFunTys doc n_pats res_ty $ \ pat_tys rhs_ty ->
107 tcMatches match_ctxt pat_tys rhs_ty match
109 n_pats = matchGroupArity match
110 doc = sep [ ptext SLIT("The lambda expression")
111 <+> quotes (pprSetDepth 1 $ pprMatches LambdaExpr match),
112 -- The pprSetDepth makes the abstraction print briefly
113 ptext SLIT("has") <+> speakNOf n_pats (ptext SLIT("argument"))]
114 match_ctxt = MC { mc_what = LambdaExpr,
115 mc_body = tcPolyExpr }
118 @tcGRHSsPat@ typechecks @[GRHSs]@ that occur in a @PatMonoBind@.
121 tcGRHSsPat :: GRHSs Name -> BoxyRhoType -> TcM (GRHSs TcId)
122 tcGRHSsPat grhss res_ty = tcGRHSs match_ctxt grhss res_ty
124 match_ctxt = MC { mc_what = PatBindRhs,
125 mc_body = tcPolyExpr }
129 %************************************************************************
133 %************************************************************************
136 tcMatches :: TcMatchCtxt
137 -> [BoxySigmaType] -- Expected pattern types
138 -> BoxyRhoType -- Expected result-type of the Match.
140 -> TcM (MatchGroup TcId)
142 data TcMatchCtxt -- c.f. TcStmtCtxt, also in this module
143 = MC { mc_what :: HsMatchContext Name, -- What kind of thing this is
144 mc_body :: LHsExpr Name -- Type checker for a body of an alternative
146 -> TcM (LHsExpr TcId) }
148 tcMatches ctxt pat_tys rhs_ty (MatchGroup matches _)
149 = do { matches' <- mapM (tcMatch ctxt pat_tys rhs_ty) matches
150 ; return (MatchGroup matches' (mkFunTys pat_tys rhs_ty)) }
153 tcMatch :: TcMatchCtxt
154 -> [BoxySigmaType] -- Expected pattern types
155 -> BoxyRhoType -- Expected result-type of the Match.
159 tcMatch ctxt pat_tys rhs_ty match
160 = wrapLocM (tc_match ctxt pat_tys rhs_ty) match
162 tc_match ctxt pat_tys rhs_ty match@(Match pats maybe_rhs_sig grhss)
163 = addErrCtxt (matchCtxt (mc_what ctxt) match) $
164 do { (pats', grhss') <- tcPats LamPat pats pat_tys rhs_ty $
165 tc_grhss ctxt maybe_rhs_sig grhss
166 ; return (Match pats' Nothing grhss') }
168 tc_grhss ctxt Nothing grhss rhs_ty
169 = tcGRHSs ctxt grhss rhs_ty -- No result signature
171 -- Result type sigs are no longer supported
172 tc_grhss ctxt (Just res_sig) grhss rhs_ty
173 = do { addErr (ptext SLIT("Ignoring (deprecated) result type signature")
175 ; tcGRHSs ctxt grhss rhs_ty }
178 tcGRHSs :: TcMatchCtxt -> GRHSs Name -> BoxyRhoType -> TcM (GRHSs TcId)
180 -- Notice that we pass in the full res_ty, so that we get
181 -- good inference from simple things like
182 -- f = \(x::forall a.a->a) -> <stuff>
183 -- We used to force it to be a monotype when there was more than one guard
184 -- but we don't need to do that any more
186 tcGRHSs ctxt (GRHSs grhss binds) res_ty
187 = do { (binds', grhss') <- tcLocalBinds binds $
188 mappM (wrapLocM (tcGRHS ctxt res_ty)) grhss
190 ; returnM (GRHSs grhss' binds') }
193 tcGRHS :: TcMatchCtxt -> BoxyRhoType -> GRHS Name -> TcM (GRHS TcId)
195 tcGRHS ctxt res_ty (GRHS guards rhs)
196 = do { (guards', rhs') <- tcStmts stmt_ctxt tcGuardStmt guards res_ty $
198 ; return (GRHS guards' rhs') }
200 stmt_ctxt = PatGuard (mc_what ctxt)
204 %************************************************************************
206 \subsection{@tcDoStmts@ typechecks a {\em list} of do statements}
208 %************************************************************************
211 tcDoStmts :: HsStmtContext Name
215 -> TcM (HsExpr TcId) -- Returns a HsDo
216 tcDoStmts ListComp stmts body res_ty
217 = do { elt_ty <- boxySplitListTy res_ty
218 ; (stmts', body') <- tcStmts ListComp (tcLcStmt listTyCon) stmts elt_ty $
219 tcBody (doBodyCtxt ListComp body) body
220 ; return (HsDo ListComp stmts' body' (mkListTy elt_ty)) }
222 tcDoStmts PArrComp stmts body res_ty
223 = do { [elt_ty] <- boxySplitTyConApp parrTyCon res_ty
224 ; (stmts', body') <- tcStmts PArrComp (tcLcStmt parrTyCon) stmts elt_ty $
225 tcBody (doBodyCtxt PArrComp body) body
226 ; return (HsDo PArrComp stmts' body' (mkPArrTy elt_ty)) }
228 tcDoStmts DoExpr stmts body res_ty
229 = do { (m_ty, elt_ty) <- boxySplitAppTy res_ty
230 ; let res_ty' = mkAppTy m_ty elt_ty -- The boxySplit consumes res_ty
231 ; (stmts', body') <- tcStmts DoExpr (tcDoStmt m_ty) stmts res_ty' $
232 tcBody (doBodyCtxt DoExpr body) body
233 ; return (HsDo DoExpr stmts' body' res_ty') }
235 tcDoStmts ctxt@(MDoExpr _) stmts body res_ty
236 = do { (m_ty, elt_ty) <- boxySplitAppTy res_ty
237 ; let res_ty' = mkAppTy m_ty elt_ty -- The boxySplit consumes res_ty
238 tc_rhs rhs = withBox liftedTypeKind $ \ pat_ty ->
239 tcMonoExpr rhs (mkAppTy m_ty pat_ty)
241 ; (stmts', body') <- tcStmts ctxt (tcMDoStmt tc_rhs) stmts res_ty' $
242 tcBody (doBodyCtxt ctxt body) body
244 ; let names = [mfixName, bindMName, thenMName, returnMName, failMName]
245 ; insts <- mapM (newMethodFromName DoOrigin m_ty) names
246 ; return (HsDo (MDoExpr (names `zip` insts)) stmts' body' res_ty') }
248 tcDoStmts ctxt stmts body res_ty = pprPanic "tcDoStmts" (pprStmtContext ctxt)
250 tcBody :: Message -> LHsExpr Name -> BoxyRhoType -> TcM (LHsExpr TcId)
251 tcBody ctxt body res_ty
252 = -- addErrCtxt ctxt $ -- This context adds little that is useful
253 tcPolyExpr body res_ty
257 %************************************************************************
261 %************************************************************************
265 = forall thing. HsStmtContext Name
267 -> BoxyRhoType -- Result type for comprehension
268 -> (BoxyRhoType -> TcM thing) -- Checker for what follows the stmt
269 -> TcM (Stmt TcId, thing)
271 -- The incoming BoxyRhoType may be refined by type refinements
272 -- before being passed to the thing_inside
274 tcStmts :: HsStmtContext Name
275 -> TcStmtChecker -- NB: higher-rank type
278 -> (BoxyRhoType -> TcM thing)
279 -> TcM ([LStmt TcId], thing)
281 -- Note the higher-rank type. stmt_chk is applied at different
282 -- types in the equations for tcStmts
284 tcStmts ctxt stmt_chk [] res_ty thing_inside
285 = do { thing <- thing_inside res_ty
286 ; return ([], thing) }
288 -- LetStmts are handled uniformly, regardless of context
289 tcStmts ctxt stmt_chk (L loc (LetStmt binds) : stmts) res_ty thing_inside
290 = do { (binds', (stmts',thing)) <- tcLocalBinds binds $
291 tcStmts ctxt stmt_chk stmts res_ty thing_inside
292 ; return (L loc (LetStmt binds') : stmts', thing) }
294 -- For the vanilla case, handle the location-setting part
295 tcStmts ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside
296 = do { (stmt', (stmts', thing)) <-
298 addErrCtxt (stmtCtxt ctxt stmt) $
299 stmt_chk ctxt stmt res_ty $ \ res_ty' ->
301 tcStmts ctxt stmt_chk stmts res_ty' $
303 ; return (L loc stmt' : stmts', thing) }
305 --------------------------------
307 tcGuardStmt :: TcStmtChecker
308 tcGuardStmt ctxt (ExprStmt guard _ _) res_ty thing_inside
309 = do { guard' <- tcMonoExpr guard boolTy
310 ; thing <- thing_inside res_ty
311 ; return (ExprStmt guard' noSyntaxExpr boolTy, thing) }
313 tcGuardStmt ctxt (BindStmt pat rhs _ _) res_ty thing_inside
314 = do { (rhs', rhs_ty) <- tcInferRho rhs
315 ; (pat', thing) <- tcPat LamPat pat rhs_ty res_ty thing_inside
316 ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
318 tcGuardStmt ctxt stmt res_ty thing_inside
319 = pprPanic "tcGuardStmt: unexpected Stmt" (ppr stmt)
322 --------------------------------
323 -- List comprehensions and PArrays
325 tcLcStmt :: TyCon -- The list/Parray type constructor ([] or PArray)
328 -- A generator, pat <- rhs
329 tcLcStmt m_tc ctxt (BindStmt pat rhs _ _) res_ty thing_inside
330 = do { (rhs', pat_ty) <- withBox liftedTypeKind $ \ ty ->
331 tcMonoExpr rhs (mkTyConApp m_tc [ty])
332 ; (pat', thing) <- tcPat LamPat pat pat_ty res_ty thing_inside
333 ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
336 tcLcStmt m_tc ctxt (ExprStmt rhs _ _) res_ty thing_inside
337 = do { rhs' <- tcMonoExpr rhs boolTy
338 ; thing <- thing_inside res_ty
339 ; return (ExprStmt rhs' noSyntaxExpr boolTy, thing) }
341 -- A parallel set of comprehensions
342 -- [ (g x, h x) | ... ; let g v = ...
343 -- | ... ; let h v = ... ]
345 -- It's possible that g,h are overloaded, so we need to feed the LIE from the
346 -- (g x, h x) up through both lots of bindings (so we get the bindInstsOfLocalFuns).
347 -- Similarly if we had an existential pattern match:
349 -- data T = forall a. Show a => C a
351 -- [ (show x, show y) | ... ; C x <- ...
352 -- | ... ; C y <- ... ]
354 -- Then we need the LIE from (show x, show y) to be simplified against
355 -- the bindings for x and y.
357 -- It's difficult to do this in parallel, so we rely on the renamer to
358 -- ensure that g,h and x,y don't duplicate, and simply grow the environment.
359 -- So the binders of the first parallel group will be in scope in the second
360 -- group. But that's fine; there's no shadowing to worry about.
362 tcLcStmt m_tc ctxt (ParStmt bndr_stmts_s) elt_ty thing_inside
363 = do { (pairs', thing) <- loop bndr_stmts_s
364 ; return (ParStmt pairs', thing) }
366 -- loop :: [([LStmt Name], [Name])] -> TcM ([([LStmt TcId], [TcId])], thing)
367 loop [] = do { thing <- thing_inside elt_ty -- No refinement from pattern
368 ; return ([], thing) } -- matching in the branches
370 loop ((stmts, names) : pairs)
371 = do { (stmts', (ids, pairs', thing))
372 <- tcStmts ctxt (tcLcStmt m_tc) stmts elt_ty $ \ elt_ty' ->
373 do { ids <- tcLookupLocalIds names
374 ; (pairs', thing) <- loop pairs
375 ; return (ids, pairs', thing) }
376 ; return ( (stmts', ids) : pairs', thing ) }
378 tcLcStmt m_tc ctxt stmt elt_ty thing_inside
379 = pprPanic "tcLcStmt: unexpected Stmt" (ppr stmt)
381 --------------------------------
383 -- The main excitement here is dealing with rebindable syntax
385 tcDoStmt :: TcType -- Monad type, m
388 tcDoStmt m_ty ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
389 = do { (rhs', pat_ty) <- withBox liftedTypeKind $ \ pat_ty ->
390 tcMonoExpr rhs (mkAppTy m_ty pat_ty)
391 -- We should use type *inference* for the RHS computations, becuase of GADTs.
392 -- do { pat <- rhs; <rest> }
394 -- case rhs of { pat -> <rest> }
395 -- We do inference on rhs, so that information about its type can be refined
396 -- when type-checking the pattern.
398 ; (pat', thing) <- tcPat LamPat pat pat_ty res_ty thing_inside
400 -- Deal with rebindable syntax; (>>=) :: m a -> (a -> m b) -> m b
401 ; let bind_ty = mkFunTys [mkAppTy m_ty pat_ty,
402 mkFunTy pat_ty res_ty] res_ty
403 ; bind_op' <- tcSyntaxOp DoOrigin bind_op bind_ty
404 -- If (but only if) the pattern can fail,
405 -- typecheck the 'fail' operator
406 ; fail_op' <- if isIrrefutableHsPat pat'
407 then return noSyntaxExpr
408 else tcSyntaxOp DoOrigin fail_op (mkFunTy stringTy res_ty)
409 ; return (BindStmt pat' rhs' bind_op' fail_op', thing) }
412 tcDoStmt m_ty ctxt (ExprStmt rhs then_op _) res_ty thing_inside
413 = do { -- Deal with rebindable syntax; (>>) :: m a -> m b -> m b
414 a_ty <- newFlexiTyVarTy liftedTypeKind
415 ; let rhs_ty = mkAppTy m_ty a_ty
416 then_ty = mkFunTys [rhs_ty, res_ty] res_ty
417 ; then_op' <- tcSyntaxOp DoOrigin then_op then_ty
418 ; rhs' <- tcPolyExpr rhs rhs_ty
419 ; thing <- thing_inside res_ty
420 ; return (ExprStmt rhs' then_op' rhs_ty, thing) }
422 tcDoStmt m_ty ctxt stmt res_ty thing_inside
423 = pprPanic "tcDoStmt: unexpected Stmt" (ppr stmt)
425 --------------------------------
427 -- The distinctive features here are
429 -- (b) no rebindable syntax
431 tcMDoStmt :: (LHsExpr Name -> TcM (LHsExpr TcId, TcType)) -- RHS inference
433 tcMDoStmt tc_rhs ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
434 = do { (rhs', pat_ty) <- tc_rhs rhs
435 ; (pat', thing) <- tcPat LamPat pat pat_ty res_ty thing_inside
436 ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
438 tcMDoStmt tc_rhs ctxt (ExprStmt rhs then_op _) res_ty thing_inside
439 = do { (rhs', elt_ty) <- tc_rhs rhs
440 ; thing <- thing_inside res_ty
441 ; return (ExprStmt rhs' noSyntaxExpr elt_ty, thing) }
443 tcMDoStmt tc_rhs ctxt (RecStmt stmts laterNames recNames _ _) res_ty thing_inside
444 = do { rec_tys <- newFlexiTyVarTys (length recNames) liftedTypeKind
445 ; let rec_ids = zipWith mkLocalId recNames rec_tys
446 ; tcExtendIdEnv rec_ids $ do
447 { (stmts', (later_ids, rec_rets))
448 <- tcStmts ctxt (tcMDoStmt tc_rhs) stmts res_ty $ \ res_ty' ->
449 -- ToDo: res_ty not really right
450 do { rec_rets <- zipWithM tc_ret recNames rec_tys
451 ; later_ids <- tcLookupLocalIds laterNames
452 ; return (later_ids, rec_rets) }
454 ; (thing,lie) <- tcExtendIdEnv later_ids (getLIE (thing_inside res_ty))
455 -- NB: The rec_ids for the recursive things
456 -- already scope over this part. This binding may shadow
457 -- some of them with polymorphic things with the same Name
458 -- (see note [RecStmt] in HsExpr)
459 ; lie_binds <- bindInstsOfLocalFuns lie later_ids
461 ; return (RecStmt stmts' later_ids rec_ids rec_rets lie_binds, thing)
464 -- Unify the types of the "final" Ids with those of "knot-tied" Ids
465 tc_ret rec_name mono_ty
466 = do { poly_id <- tcLookupId rec_name
467 -- poly_id may have a polymorphic type
468 -- but mono_ty is just a monomorphic type variable
469 ; co_fn <- tcSubExp (idType poly_id) mono_ty
470 ; return (mkHsCoerce co_fn (HsVar poly_id)) }
472 tcMDoStmt tc_rhs ctxt stmt res_ty thing_inside
473 = pprPanic "tcMDoStmt: unexpected Stmt" (ppr stmt)
478 %************************************************************************
480 \subsection{Errors and contexts}
482 %************************************************************************
484 @sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same
485 number of args are used in each equation.
488 checkArgs :: Name -> MatchGroup Name -> TcM ()
489 checkArgs fun (MatchGroup (match1:matches) _)
490 | null bad_matches = return ()
492 = failWithTc (vcat [ptext SLIT("Equations for") <+> quotes (ppr fun) <+>
493 ptext SLIT("have different numbers of arguments"),
494 nest 2 (ppr (getLoc match1)),
495 nest 2 (ppr (getLoc (head bad_matches)))])
497 n_args1 = args_in_match match1
498 bad_matches = [m | m <- matches, args_in_match m /= n_args1]
500 args_in_match :: LMatch Name -> Int
501 args_in_match (L _ (Match pats _ _)) = length pats
502 checkArgs fun other = panic "TcPat.checkArgs" -- Matches always non-empty
506 matchCtxt ctxt match = hang (ptext SLIT("In") <+> pprMatchContext ctxt <> colon)
507 4 (pprMatch ctxt match)
509 doBodyCtxt :: HsStmtContext Name -> LHsExpr Name -> SDoc
510 doBodyCtxt ctxt body = hang (ptext SLIT("In the result of") <+> pprStmtContext ctxt <> colon)
513 stmtCtxt ctxt stmt = hang (ptext SLIT("In") <+> pprStmtContext ctxt <> colon)