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(..),
9 tcStmts, tcDoStmts, tcBody,
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(..),
21 pprMatch, isIrrefutableHsPat, mkHsCoerce,
22 mkLHsCoerce, pprMatchContext, pprStmtContext,
23 noSyntaxExpr, matchGroupArity, pprMatches,
27 import TcGadt ( Refinement, emptyRefinement, refineResType )
28 import Inst ( newMethodFromName )
29 import TcEnv ( TcId, tcLookupLocalIds, tcLookupId, tcExtendIdEnv )
30 import TcPat ( tcLamPats, tcLamPat )
31 import TcMType ( newFlexiTyVarTy, newFlexiTyVarTys )
32 import TcType ( TcType, TcRhoType,
33 BoxySigmaType, BoxyRhoType,
34 mkFunTys, mkFunTy, mkAppTy, mkTyConApp,
36 import TcBinds ( tcLocalBinds )
37 import TcUnify ( boxySplitAppTy, boxySplitTyConApp, boxySplitListTy,
38 subFunTys, tcSubExp, withBox )
39 import TcSimplify ( bindInstsOfLocalFuns )
41 import TysWiredIn ( stringTy, boolTy, parrTyCon, listTyCon, mkListTy, mkPArrTy )
42 import PrelNames ( bindMName, returnMName, mfixName, thenMName, failMName )
43 import Id ( idType, mkLocalId )
44 import TyCon ( TyCon )
46 import SrcLoc ( Located(..), getLoc )
49 %************************************************************************
51 \subsection{tcMatchesFun, tcMatchesCase}
53 %************************************************************************
55 @tcMatchesFun@ typechecks a @[Match]@ list which occurs in a
56 @FunMonoBind@. The second argument is the name of the function, which
57 is used in error messages. It checks that all the equations have the
58 same number of arguments before using @tcMatches@ to do the work.
63 -> BoxyRhoType -- Expected type of function
64 -> TcM (ExprCoFn, MatchGroup TcId) -- Returns type of body
66 tcMatchesFun fun_name matches exp_ty
67 = do { -- Check that they all have the same no of arguments
68 -- Location is in the monad, set the caller 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 checkArgs fun_name matches
75 -- ToDo: Don't use "expected" stuff if there ain't a type signature
76 -- because inconsistency between branches
77 -- may show up as something wrong with the (non-existent) type signature
79 -- This is one of two places places we call subFunTys
80 -- The point is that if expected_y is a "hole", we want
81 -- to make pat_tys and rhs_ty as "holes" too.
82 ; subFunTys doc n_pats exp_ty $ \ pat_tys rhs_ty ->
83 tcMatches match_ctxt pat_tys rhs_ty matches
86 doc = ptext SLIT("The equation(s) for") <+> quotes (ppr fun_name)
87 <+> ptext SLIT("have") <+> speakNOf n_pats (ptext SLIT("argument"))
88 n_pats = matchGroupArity matches
89 match_ctxt = MC { mc_what = FunRhs fun_name, mc_body = tcBody }
92 @tcMatchesCase@ doesn't do the argument-count check because the
93 parser guarantees that each equation has exactly one argument.
96 tcMatchesCase :: TcMatchCtxt -- Case context
97 -> TcRhoType -- Type of scrutinee
98 -> MatchGroup Name -- The case alternatives
99 -> BoxyRhoType -- Type of whole case expressions
100 -> TcM (MatchGroup TcId) -- Translated alternatives
102 tcMatchesCase ctxt scrut_ty matches res_ty
103 = tcMatches ctxt [scrut_ty] res_ty matches
105 tcMatchLambda :: MatchGroup Name -> BoxyRhoType -> TcM (ExprCoFn, MatchGroup TcId)
106 tcMatchLambda match res_ty
107 = subFunTys doc n_pats res_ty $ \ pat_tys rhs_ty ->
108 tcMatches match_ctxt pat_tys rhs_ty match
110 n_pats = matchGroupArity match
111 doc = sep [ ptext SLIT("The lambda expression")
112 <+> quotes (pprSetDepth 1 $ pprMatches LambdaExpr match),
113 -- The pprSetDepth makes the abstraction print briefly
114 ptext SLIT("has") <+> speakNOf n_pats (ptext SLIT("argument"))]
115 match_ctxt = MC { mc_what = LambdaExpr,
119 @tcGRHSsPat@ typechecks @[GRHSs]@ that occur in a @PatMonoBind@.
122 tcGRHSsPat :: GRHSs Name -> BoxyRhoType -> TcM (GRHSs TcId)
123 -- Used for pattern bindings
124 tcGRHSsPat grhss res_ty = tcGRHSs match_ctxt grhss (emptyRefinement, res_ty)
125 -- emptyRefinement: no refinement in a pattern binding
127 match_ctxt = MC { mc_what = PatBindRhs,
132 %************************************************************************
136 %************************************************************************
139 tcMatches :: TcMatchCtxt
140 -> [BoxySigmaType] -- Expected pattern types
141 -> BoxyRhoType -- Expected result-type of the Match.
143 -> TcM (MatchGroup TcId)
145 data TcMatchCtxt -- c.f. TcStmtCtxt, also in this module
146 = MC { mc_what :: HsMatchContext Name, -- What kind of thing this is
147 mc_body :: LHsExpr Name -- Type checker for a body of an alternative
148 -> (Refinement, BoxyRhoType)
149 -> TcM (LHsExpr TcId) }
151 tcMatches ctxt pat_tys rhs_ty (MatchGroup matches _)
152 = do { matches' <- mapM (tcMatch ctxt pat_tys rhs_ty) matches
153 ; return (MatchGroup matches' (mkFunTys pat_tys rhs_ty)) }
156 tcMatch :: TcMatchCtxt
157 -> [BoxySigmaType] -- Expected pattern types
158 -> BoxyRhoType -- Expected result-type of the Match.
162 tcMatch ctxt pat_tys rhs_ty match
163 = wrapLocM (tc_match ctxt pat_tys rhs_ty) match
165 tc_match ctxt pat_tys rhs_ty match@(Match pats maybe_rhs_sig grhss)
166 = addErrCtxt (matchCtxt (mc_what ctxt) match) $
167 do { (pats', grhss') <- tcLamPats pats pat_tys rhs_ty $
168 tc_grhss ctxt maybe_rhs_sig grhss
169 ; return (Match pats' Nothing grhss') }
171 tc_grhss ctxt Nothing grhss rhs_ty
172 = tcGRHSs ctxt grhss rhs_ty -- No result signature
174 -- Result type sigs are no longer supported
175 tc_grhss ctxt (Just res_sig) grhss (co, rhs_ty)
176 = do { addErr (ptext SLIT("Ignoring (deprecated) result type signature")
178 ; tcGRHSs ctxt grhss (co, rhs_ty) }
181 tcGRHSs :: TcMatchCtxt -> GRHSs Name -> (Refinement, BoxyRhoType)
184 -- Notice that we pass in the full res_ty, so that we get
185 -- good inference from simple things like
186 -- f = \(x::forall a.a->a) -> <stuff>
187 -- We used to force it to be a monotype when there was more than one guard
188 -- but we don't need to do that any more
190 tcGRHSs ctxt (GRHSs grhss binds) res_ty
191 = do { (binds', grhss') <- tcLocalBinds binds $
192 mappM (wrapLocM (tcGRHS ctxt res_ty)) grhss
194 ; returnM (GRHSs grhss' binds') }
197 tcGRHS :: TcMatchCtxt -> (Refinement, BoxyRhoType) -> GRHS Name -> TcM (GRHS TcId)
199 tcGRHS ctxt res_ty (GRHS guards rhs)
200 = do { (guards', rhs') <- tcStmts stmt_ctxt tcGuardStmt guards res_ty $
202 ; return (GRHS guards' rhs') }
204 stmt_ctxt = PatGuard (mc_what ctxt)
208 %************************************************************************
210 \subsection{@tcDoStmts@ typechecks a {\em list} of do statements}
212 %************************************************************************
215 tcDoStmts :: HsStmtContext Name
219 -> TcM (HsExpr TcId) -- Returns a HsDo
220 tcDoStmts ListComp stmts body res_ty
221 = do { elt_ty <- boxySplitListTy res_ty
222 ; (stmts', body') <- tcStmts ListComp (tcLcStmt listTyCon) stmts
223 (emptyRefinement,elt_ty) $
225 ; return (HsDo ListComp stmts' body' (mkListTy elt_ty)) }
227 tcDoStmts PArrComp stmts body res_ty
228 = do { [elt_ty] <- boxySplitTyConApp parrTyCon res_ty
229 ; (stmts', body') <- tcStmts PArrComp (tcLcStmt parrTyCon) stmts
230 (emptyRefinement, elt_ty) $
232 ; return (HsDo PArrComp stmts' body' (mkPArrTy elt_ty)) }
234 tcDoStmts DoExpr stmts body res_ty
235 = do { (m_ty, elt_ty) <- boxySplitAppTy res_ty
236 ; let res_ty' = mkAppTy m_ty elt_ty -- The boxySplit consumes res_ty
237 ; (stmts', body') <- tcStmts DoExpr (tcDoStmt m_ty) stmts
238 (emptyRefinement, res_ty') $
240 ; return (HsDo DoExpr stmts' body' res_ty') }
242 tcDoStmts ctxt@(MDoExpr _) stmts body res_ty
243 = do { (m_ty, elt_ty) <- boxySplitAppTy res_ty
244 ; let res_ty' = mkAppTy m_ty elt_ty -- The boxySplit consumes res_ty
245 tc_rhs rhs = withBox liftedTypeKind $ \ pat_ty ->
246 tcMonoExpr rhs (mkAppTy m_ty pat_ty)
248 ; (stmts', body') <- tcStmts ctxt (tcMDoStmt tc_rhs) stmts
249 (emptyRefinement, res_ty') $
252 ; let names = [mfixName, bindMName, thenMName, returnMName, failMName]
253 ; insts <- mapM (newMethodFromName DoOrigin m_ty) names
254 ; return (HsDo (MDoExpr (names `zip` insts)) stmts' body' res_ty') }
256 tcDoStmts ctxt stmts body res_ty = pprPanic "tcDoStmts" (pprStmtContext ctxt)
258 tcBody :: LHsExpr Name -> (Refinement, BoxyRhoType) -> TcM (LHsExpr TcId)
259 tcBody body (reft, res_ty)
260 = do { traceTc (text "tcBody" <+> ppr res_ty <+> ppr reft)
261 ; let (co, res_ty') = refineResType reft res_ty
262 ; body' <- tcPolyExpr body res_ty'
263 ; return (mkLHsCoerce co body') }
267 %************************************************************************
271 %************************************************************************
275 = forall thing. HsStmtContext Name
277 -> (Refinement, BoxyRhoType) -- Result type for comprehension
278 -> ((Refinement,BoxyRhoType) -> TcM thing) -- Checker for what follows the stmt
279 -> TcM (Stmt TcId, thing)
281 -- The incoming BoxyRhoType may be refined by type refinements
282 -- before being passed to the thing_inside
284 tcStmts :: HsStmtContext Name
285 -> TcStmtChecker -- NB: higher-rank type
287 -> (Refinement, BoxyRhoType)
288 -> ((Refinement, BoxyRhoType) -> TcM thing)
289 -> TcM ([LStmt TcId], thing)
291 -- Note the higher-rank type. stmt_chk is applied at different
292 -- types in the equations for tcStmts
294 tcStmts ctxt stmt_chk [] res_ty thing_inside
295 = do { thing <- thing_inside res_ty
296 ; return ([], thing) }
298 -- LetStmts are handled uniformly, regardless of context
299 tcStmts ctxt stmt_chk (L loc (LetStmt binds) : stmts) res_ty thing_inside
300 = do { (binds', (stmts',thing)) <- tcLocalBinds binds $
301 tcStmts ctxt stmt_chk stmts res_ty thing_inside
302 ; return (L loc (LetStmt binds') : stmts', thing) }
304 -- For the vanilla case, handle the location-setting part
305 tcStmts ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside
306 = do { (stmt', (stmts', thing)) <-
308 addErrCtxt (stmtCtxt ctxt stmt) $
309 stmt_chk ctxt stmt res_ty $ \ res_ty' ->
311 tcStmts ctxt stmt_chk stmts res_ty' $
313 ; return (L loc stmt' : stmts', thing) }
315 --------------------------------
317 tcGuardStmt :: TcStmtChecker
318 tcGuardStmt ctxt (ExprStmt guard _ _) res_ty thing_inside
319 = do { guard' <- tcMonoExpr guard boolTy
320 ; thing <- thing_inside res_ty
321 ; return (ExprStmt guard' noSyntaxExpr boolTy, thing) }
323 tcGuardStmt ctxt (BindStmt pat rhs _ _) res_ty thing_inside
324 = do { (rhs', rhs_ty) <- tcInferRho rhs
325 ; (pat', thing) <- tcLamPat pat rhs_ty res_ty thing_inside
326 ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
328 tcGuardStmt ctxt stmt res_ty thing_inside
329 = pprPanic "tcGuardStmt: unexpected Stmt" (ppr stmt)
332 --------------------------------
333 -- List comprehensions and PArrays
335 tcLcStmt :: TyCon -- The list/Parray type constructor ([] or PArray)
338 -- A generator, pat <- rhs
339 tcLcStmt m_tc ctxt (BindStmt pat rhs _ _) res_ty thing_inside
340 = do { (rhs', pat_ty) <- withBox liftedTypeKind $ \ ty ->
341 tcMonoExpr rhs (mkTyConApp m_tc [ty])
342 ; (pat', thing) <- tcLamPat pat pat_ty res_ty thing_inside
343 ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
346 tcLcStmt m_tc ctxt (ExprStmt rhs _ _) res_ty thing_inside
347 = do { rhs' <- tcMonoExpr rhs boolTy
348 ; thing <- thing_inside res_ty
349 ; return (ExprStmt rhs' noSyntaxExpr boolTy, thing) }
351 -- A parallel set of comprehensions
352 -- [ (g x, h x) | ... ; let g v = ...
353 -- | ... ; let h v = ... ]
355 -- It's possible that g,h are overloaded, so we need to feed the LIE from the
356 -- (g x, h x) up through both lots of bindings (so we get the bindInstsOfLocalFuns).
357 -- Similarly if we had an existential pattern match:
359 -- data T = forall a. Show a => C a
361 -- [ (show x, show y) | ... ; C x <- ...
362 -- | ... ; C y <- ... ]
364 -- Then we need the LIE from (show x, show y) to be simplified against
365 -- the bindings for x and y.
367 -- It's difficult to do this in parallel, so we rely on the renamer to
368 -- ensure that g,h and x,y don't duplicate, and simply grow the environment.
369 -- So the binders of the first parallel group will be in scope in the second
370 -- group. But that's fine; there's no shadowing to worry about.
372 tcLcStmt m_tc ctxt (ParStmt bndr_stmts_s) elt_ty thing_inside
373 = do { (pairs', thing) <- loop bndr_stmts_s
374 ; return (ParStmt pairs', thing) }
376 -- loop :: [([LStmt Name], [Name])] -> TcM ([([LStmt TcId], [TcId])], thing)
377 loop [] = do { thing <- thing_inside elt_ty -- No refinement from pattern
378 ; return ([], thing) } -- matching in the branches
380 loop ((stmts, names) : pairs)
381 = do { (stmts', (ids, pairs', thing))
382 <- tcStmts ctxt (tcLcStmt m_tc) stmts elt_ty $ \ elt_ty' ->
383 do { ids <- tcLookupLocalIds names
384 ; (pairs', thing) <- loop pairs
385 ; return (ids, pairs', thing) }
386 ; return ( (stmts', ids) : pairs', thing ) }
388 tcLcStmt m_tc ctxt stmt elt_ty thing_inside
389 = pprPanic "tcLcStmt: unexpected Stmt" (ppr stmt)
391 --------------------------------
393 -- The main excitement here is dealing with rebindable syntax
395 tcDoStmt :: TcType -- Monad type, m
398 tcDoStmt m_ty ctxt (BindStmt pat rhs bind_op fail_op) reft_res_ty@(_,res_ty) thing_inside
399 = do { (rhs', pat_ty) <- withBox liftedTypeKind $ \ pat_ty ->
400 tcMonoExpr rhs (mkAppTy m_ty pat_ty)
401 -- We should use type *inference* for the RHS computations, becuase of GADTs.
402 -- do { pat <- rhs; <rest> }
404 -- case rhs of { pat -> <rest> }
405 -- We do inference on rhs, so that information about its type can be refined
406 -- when type-checking the pattern.
408 ; (pat', thing) <- tcLamPat pat pat_ty reft_res_ty thing_inside
410 -- Deal with rebindable syntax; (>>=) :: m a -> (a -> m b) -> m b
411 ; let bind_ty = mkFunTys [mkAppTy m_ty pat_ty,
412 mkFunTy pat_ty res_ty] res_ty
413 ; bind_op' <- tcSyntaxOp DoOrigin bind_op bind_ty
414 -- If (but only if) the pattern can fail,
415 -- typecheck the 'fail' operator
416 ; fail_op' <- if isIrrefutableHsPat pat'
417 then return noSyntaxExpr
418 else tcSyntaxOp DoOrigin fail_op (mkFunTy stringTy res_ty)
419 ; return (BindStmt pat' rhs' bind_op' fail_op', thing) }
422 tcDoStmt m_ty ctxt (ExprStmt rhs then_op _) reft_res_ty@(_,res_ty) thing_inside
423 = do { -- Deal with rebindable syntax; (>>) :: m a -> m b -> m b
424 a_ty <- newFlexiTyVarTy liftedTypeKind
425 ; let rhs_ty = mkAppTy m_ty a_ty
426 then_ty = mkFunTys [rhs_ty, res_ty] res_ty
427 ; then_op' <- tcSyntaxOp DoOrigin then_op then_ty
428 ; rhs' <- tcPolyExpr rhs rhs_ty
429 ; thing <- thing_inside reft_res_ty
430 ; return (ExprStmt rhs' then_op' rhs_ty, thing) }
432 tcDoStmt m_ty ctxt stmt res_ty thing_inside
433 = pprPanic "tcDoStmt: unexpected Stmt" (ppr stmt)
435 --------------------------------
437 -- The distinctive features here are
439 -- (b) no rebindable syntax
441 tcMDoStmt :: (LHsExpr Name -> TcM (LHsExpr TcId, TcType)) -- RHS inference
443 tcMDoStmt tc_rhs ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
444 = do { (rhs', pat_ty) <- tc_rhs rhs
445 ; (pat', thing) <- tcLamPat pat pat_ty res_ty thing_inside
446 ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
448 tcMDoStmt tc_rhs ctxt (ExprStmt rhs then_op _) res_ty thing_inside
449 = do { (rhs', elt_ty) <- tc_rhs rhs
450 ; thing <- thing_inside res_ty
451 ; return (ExprStmt rhs' noSyntaxExpr elt_ty, thing) }
453 tcMDoStmt tc_rhs ctxt (RecStmt stmts laterNames recNames _ _) res_ty thing_inside
454 = do { rec_tys <- newFlexiTyVarTys (length recNames) liftedTypeKind
455 ; let rec_ids = zipWith mkLocalId recNames rec_tys
456 ; tcExtendIdEnv rec_ids $ do
457 { (stmts', (later_ids, rec_rets))
458 <- tcStmts ctxt (tcMDoStmt tc_rhs) stmts res_ty $ \ res_ty' ->
459 -- ToDo: res_ty not really right
460 do { rec_rets <- zipWithM tc_ret recNames rec_tys
461 ; later_ids <- tcLookupLocalIds laterNames
462 ; return (later_ids, rec_rets) }
464 ; (thing,lie) <- tcExtendIdEnv later_ids (getLIE (thing_inside res_ty))
465 -- NB: The rec_ids for the recursive things
466 -- already scope over this part. This binding may shadow
467 -- some of them with polymorphic things with the same Name
468 -- (see note [RecStmt] in HsExpr)
469 ; lie_binds <- bindInstsOfLocalFuns lie later_ids
471 ; return (RecStmt stmts' later_ids rec_ids rec_rets lie_binds, thing)
474 -- Unify the types of the "final" Ids with those of "knot-tied" Ids
475 tc_ret rec_name mono_ty
476 = do { poly_id <- tcLookupId rec_name
477 -- poly_id may have a polymorphic type
478 -- but mono_ty is just a monomorphic type variable
479 ; co_fn <- tcSubExp (idType poly_id) mono_ty
480 ; return (mkHsCoerce co_fn (HsVar poly_id)) }
482 tcMDoStmt tc_rhs ctxt stmt res_ty thing_inside
483 = pprPanic "tcMDoStmt: unexpected Stmt" (ppr stmt)
488 %************************************************************************
490 \subsection{Errors and contexts}
492 %************************************************************************
494 @sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same
495 number of args are used in each equation.
498 checkArgs :: Name -> MatchGroup Name -> TcM ()
499 checkArgs fun (MatchGroup (match1:matches) _)
500 | null bad_matches = return ()
502 = failWithTc (vcat [ptext SLIT("Equations for") <+> quotes (ppr fun) <+>
503 ptext SLIT("have different numbers of arguments"),
504 nest 2 (ppr (getLoc match1)),
505 nest 2 (ppr (getLoc (head bad_matches)))])
507 n_args1 = args_in_match match1
508 bad_matches = [m | m <- matches, args_in_match m /= n_args1]
510 args_in_match :: LMatch Name -> Int
511 args_in_match (L _ (Match pats _ _)) = length pats
512 checkArgs fun other = panic "TcPat.checkArgs" -- Matches always non-empty
516 matchCtxt ctxt match = hang (ptext SLIT("In") <+> pprMatchContext ctxt <> colon)
517 4 (pprMatch ctxt match)
519 stmtCtxt ctxt stmt = hang (ptext SLIT("In") <+> pprStmtContext ctxt <> colon)