2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
6 TcMatches: Typecheck some @Matches@
9 module TcMatches ( tcMatchesFun, tcGRHSsPat, tcMatchesCase, tcMatchLambda,
10 matchCtxt, TcMatchCtxt(..),
11 tcStmts, tcDoStmts, tcBody,
12 tcDoStmt, tcMDoStmt, tcGuardStmt
15 #include "HsVersions.h"
17 import {-# SOURCE #-} TcExpr( tcSyntaxOp, tcInferRho, tcMonoExpr, tcPolyExpr )
39 %************************************************************************
41 \subsection{tcMatchesFun, tcMatchesCase}
43 %************************************************************************
45 @tcMatchesFun@ typechecks a @[Match]@ list which occurs in a
46 @FunMonoBind@. The second argument is the name of the function, which
47 is used in error messages. It checks that all the equations have the
48 same number of arguments before using @tcMatches@ to do the work.
53 -> BoxyRhoType -- Expected type of function
54 -> TcM (HsWrapper, MatchGroup TcId) -- Returns type of body
56 tcMatchesFun fun_name matches exp_ty
57 = do { -- Check that they all have the same no of arguments
58 -- Location is in the monad, set the caller so that
59 -- any inter-equation error messages get some vaguely
60 -- sensible location. Note: we have to do this odd
61 -- ann-grabbing, because we don't always have annotations in
62 -- hand when we call tcMatchesFun...
63 checkArgs fun_name matches
65 -- ToDo: Don't use "expected" stuff if there ain't a type signature
66 -- because inconsistency between branches
67 -- may show up as something wrong with the (non-existent) type signature
69 -- This is one of two places places we call subFunTys
70 -- The point is that if expected_y is a "hole", we want
71 -- to make pat_tys and rhs_ty as "holes" too.
72 ; subFunTys doc n_pats exp_ty $ \ pat_tys rhs_ty ->
73 tcMatches match_ctxt pat_tys rhs_ty matches
76 doc = ptext SLIT("The equation(s) for") <+> quotes (ppr fun_name)
77 <+> ptext SLIT("have") <+> speakNOf n_pats (ptext SLIT("argument"))
78 n_pats = matchGroupArity matches
79 match_ctxt = MC { mc_what = FunRhs fun_name, mc_body = tcBody }
82 @tcMatchesCase@ doesn't do the argument-count check because the
83 parser guarantees that each equation has exactly one argument.
86 tcMatchesCase :: TcMatchCtxt -- Case context
87 -> TcRhoType -- Type of scrutinee
88 -> MatchGroup Name -- The case alternatives
89 -> BoxyRhoType -- Type of whole case expressions
90 -> TcM (MatchGroup TcId) -- Translated alternatives
92 tcMatchesCase ctxt scrut_ty matches res_ty
93 = tcMatches ctxt [scrut_ty] res_ty matches
95 tcMatchLambda :: MatchGroup Name -> BoxyRhoType -> TcM (HsWrapper, MatchGroup TcId)
96 tcMatchLambda match res_ty
97 = subFunTys doc n_pats res_ty $ \ pat_tys rhs_ty ->
98 tcMatches match_ctxt pat_tys rhs_ty match
100 n_pats = matchGroupArity match
101 doc = sep [ ptext SLIT("The lambda expression")
102 <+> quotes (pprSetDepth 1 $ pprMatches LambdaExpr match),
103 -- The pprSetDepth makes the abstraction print briefly
104 ptext SLIT("has") <+> speakNOf n_pats (ptext SLIT("argument"))]
105 match_ctxt = MC { mc_what = LambdaExpr,
109 @tcGRHSsPat@ typechecks @[GRHSs]@ that occur in a @PatMonoBind@.
112 tcGRHSsPat :: GRHSs Name -> BoxyRhoType -> TcM (GRHSs TcId)
113 -- Used for pattern bindings
114 tcGRHSsPat grhss res_ty = tcGRHSs match_ctxt grhss (emptyRefinement, res_ty)
115 -- emptyRefinement: no refinement in a pattern binding
117 match_ctxt = MC { mc_what = PatBindRhs,
122 %************************************************************************
126 %************************************************************************
129 tcMatches :: TcMatchCtxt
130 -> [BoxySigmaType] -- Expected pattern types
131 -> BoxyRhoType -- Expected result-type of the Match.
133 -> TcM (MatchGroup TcId)
135 data TcMatchCtxt -- c.f. TcStmtCtxt, also in this module
136 = MC { mc_what :: HsMatchContext Name, -- What kind of thing this is
137 mc_body :: LHsExpr Name -- Type checker for a body of an alternative
138 -> (Refinement, BoxyRhoType)
139 -> TcM (LHsExpr TcId) }
141 tcMatches ctxt pat_tys rhs_ty (MatchGroup matches _)
142 = do { matches' <- mapM (tcMatch ctxt pat_tys rhs_ty) matches
143 ; return (MatchGroup matches' (mkFunTys pat_tys rhs_ty)) }
146 tcMatch :: TcMatchCtxt
147 -> [BoxySigmaType] -- Expected pattern types
148 -> BoxyRhoType -- Expected result-type of the Match.
152 tcMatch ctxt pat_tys rhs_ty match
153 = wrapLocM (tc_match ctxt pat_tys rhs_ty) match
155 tc_match ctxt pat_tys rhs_ty match@(Match pats maybe_rhs_sig grhss)
156 = add_match_ctxt match $
157 do { (pats', grhss') <- tcLamPats pats pat_tys rhs_ty $
158 tc_grhss ctxt maybe_rhs_sig grhss
159 ; return (Match pats' Nothing grhss') }
161 tc_grhss ctxt Nothing grhss rhs_ty
162 = tcGRHSs ctxt grhss rhs_ty -- No result signature
164 -- Result type sigs are no longer supported
165 tc_grhss ctxt (Just res_sig) grhss (co, rhs_ty)
166 = do { addErr (ptext SLIT("Ignoring (deprecated) result type signature")
168 ; tcGRHSs ctxt grhss (co, rhs_ty) }
170 -- For (\x -> e), tcExpr has already said "In the expresssion \x->e"
171 -- so we don't want to add "In the lambda abstraction \x->e"
172 add_match_ctxt match thing_inside
173 = case mc_what ctxt of
174 LambdaExpr -> thing_inside
175 m_ctxt -> addErrCtxt (matchCtxt m_ctxt match) thing_inside
178 tcGRHSs :: TcMatchCtxt -> GRHSs Name -> (Refinement, BoxyRhoType)
181 -- Notice that we pass in the full res_ty, so that we get
182 -- good inference from simple things like
183 -- f = \(x::forall a.a->a) -> <stuff>
184 -- We used to force it to be a monotype when there was more than one guard
185 -- but we don't need to do that any more
187 tcGRHSs ctxt (GRHSs grhss binds) res_ty
188 = do { (binds', grhss') <- tcLocalBinds binds $
189 mappM (wrapLocM (tcGRHS ctxt res_ty)) grhss
191 ; returnM (GRHSs grhss' binds') }
194 tcGRHS :: TcMatchCtxt -> (Refinement, BoxyRhoType) -> GRHS Name -> TcM (GRHS TcId)
196 tcGRHS ctxt res_ty (GRHS guards rhs)
197 = do { (guards', rhs') <- tcStmts stmt_ctxt tcGuardStmt guards res_ty $
199 ; return (GRHS guards' rhs') }
201 stmt_ctxt = PatGuard (mc_what ctxt)
205 %************************************************************************
207 \subsection{@tcDoStmts@ typechecks a {\em list} of do statements}
209 %************************************************************************
212 tcDoStmts :: HsStmtContext Name
216 -> TcM (HsExpr TcId) -- Returns a HsDo
217 tcDoStmts ListComp stmts body res_ty
218 = do { elt_ty <- boxySplitListTy res_ty
219 ; (stmts', body') <- tcStmts ListComp (tcLcStmt listTyCon) stmts
220 (emptyRefinement,elt_ty) $
222 ; return (HsDo ListComp stmts' body' (mkListTy elt_ty)) }
224 tcDoStmts PArrComp stmts body res_ty
225 = do { [elt_ty] <- boxySplitTyConApp parrTyCon res_ty
226 ; (stmts', body') <- tcStmts PArrComp (tcLcStmt parrTyCon) stmts
227 (emptyRefinement, elt_ty) $
229 ; return (HsDo PArrComp stmts' body' (mkPArrTy elt_ty)) }
231 tcDoStmts DoExpr stmts body res_ty
232 = do { (m_ty, elt_ty) <- boxySplitAppTy res_ty
233 ; let res_ty' = mkAppTy m_ty elt_ty -- The boxySplit consumes res_ty
234 ; (stmts', body') <- tcStmts DoExpr (tcDoStmt m_ty) stmts
235 (emptyRefinement, res_ty') $
237 ; return (HsDo DoExpr stmts' body' res_ty') }
239 tcDoStmts ctxt@(MDoExpr _) stmts body res_ty
240 = do { (m_ty, elt_ty) <- boxySplitAppTy res_ty
241 ; let res_ty' = mkAppTy m_ty elt_ty -- The boxySplit consumes res_ty
242 tc_rhs rhs = withBox liftedTypeKind $ \ pat_ty ->
243 tcMonoExpr rhs (mkAppTy m_ty pat_ty)
245 ; (stmts', body') <- tcStmts ctxt (tcMDoStmt tc_rhs) stmts
246 (emptyRefinement, res_ty') $
249 ; let names = [mfixName, bindMName, thenMName, returnMName, failMName]
250 ; insts <- mapM (newMethodFromName DoOrigin m_ty) names
251 ; return (HsDo (MDoExpr (names `zip` insts)) stmts' body' res_ty') }
253 tcDoStmts ctxt stmts body res_ty = pprPanic "tcDoStmts" (pprStmtContext ctxt)
255 tcBody :: LHsExpr Name -> (Refinement, BoxyRhoType) -> TcM (LHsExpr TcId)
256 tcBody body (reft, res_ty)
257 = do { traceTc (text "tcBody" <+> ppr res_ty <+> ppr reft)
258 ; let (co, res_ty') = refineResType reft res_ty
259 ; body' <- tcPolyExpr body res_ty'
260 ; return (mkLHsWrap co body') }
264 %************************************************************************
268 %************************************************************************
272 = forall thing. HsStmtContext Name
274 -> (Refinement, BoxyRhoType) -- Result type for comprehension
275 -> ((Refinement,BoxyRhoType) -> TcM thing) -- Checker for what follows the stmt
276 -> TcM (Stmt TcId, thing)
278 -- The incoming BoxyRhoType may be refined by type refinements
279 -- before being passed to the thing_inside
281 tcStmts :: HsStmtContext Name
282 -> TcStmtChecker -- NB: higher-rank type
284 -> (Refinement, BoxyRhoType)
285 -> ((Refinement, BoxyRhoType) -> TcM thing)
286 -> TcM ([LStmt TcId], thing)
288 -- Note the higher-rank type. stmt_chk is applied at different
289 -- types in the equations for tcStmts
291 tcStmts ctxt stmt_chk [] res_ty thing_inside
292 = do { thing <- thing_inside res_ty
293 ; return ([], thing) }
295 -- LetStmts are handled uniformly, regardless of context
296 tcStmts ctxt stmt_chk (L loc (LetStmt binds) : stmts) res_ty thing_inside
297 = do { (binds', (stmts',thing)) <- tcLocalBinds binds $
298 tcStmts ctxt stmt_chk stmts res_ty thing_inside
299 ; return (L loc (LetStmt binds') : stmts', thing) }
301 -- For the vanilla case, handle the location-setting part
302 tcStmts ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside
303 = do { (stmt', (stmts', thing)) <-
305 addErrCtxt (stmtCtxt ctxt stmt) $
306 stmt_chk ctxt stmt res_ty $ \ res_ty' ->
308 tcStmts ctxt stmt_chk stmts res_ty' $
310 ; return (L loc stmt' : stmts', thing) }
312 --------------------------------
314 tcGuardStmt :: TcStmtChecker
315 tcGuardStmt ctxt (ExprStmt guard _ _) res_ty thing_inside
316 = do { guard' <- tcMonoExpr guard boolTy
317 ; thing <- thing_inside res_ty
318 ; return (ExprStmt guard' noSyntaxExpr boolTy, thing) }
320 tcGuardStmt ctxt (BindStmt pat rhs _ _) res_ty thing_inside
321 = do { (rhs', rhs_ty) <- tcInferRho rhs
322 ; (pat', thing) <- tcLamPat pat rhs_ty res_ty thing_inside
323 ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
325 tcGuardStmt ctxt stmt res_ty thing_inside
326 = pprPanic "tcGuardStmt: unexpected Stmt" (ppr stmt)
329 --------------------------------
330 -- List comprehensions and PArrays
332 tcLcStmt :: TyCon -- The list/Parray type constructor ([] or PArray)
335 -- A generator, pat <- rhs
336 tcLcStmt m_tc ctxt (BindStmt pat rhs _ _) res_ty thing_inside
337 = do { (rhs', pat_ty) <- withBox liftedTypeKind $ \ ty ->
338 tcMonoExpr rhs (mkTyConApp m_tc [ty])
339 ; (pat', thing) <- tcLamPat pat pat_ty res_ty thing_inside
340 ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
343 tcLcStmt m_tc ctxt (ExprStmt rhs _ _) res_ty thing_inside
344 = do { rhs' <- tcMonoExpr rhs boolTy
345 ; thing <- thing_inside res_ty
346 ; return (ExprStmt rhs' noSyntaxExpr boolTy, thing) }
348 -- A parallel set of comprehensions
349 -- [ (g x, h x) | ... ; let g v = ...
350 -- | ... ; let h v = ... ]
352 -- It's possible that g,h are overloaded, so we need to feed the LIE from the
353 -- (g x, h x) up through both lots of bindings (so we get the bindInstsOfLocalFuns).
354 -- Similarly if we had an existential pattern match:
356 -- data T = forall a. Show a => C a
358 -- [ (show x, show y) | ... ; C x <- ...
359 -- | ... ; C y <- ... ]
361 -- Then we need the LIE from (show x, show y) to be simplified against
362 -- the bindings for x and y.
364 -- It's difficult to do this in parallel, so we rely on the renamer to
365 -- ensure that g,h and x,y don't duplicate, and simply grow the environment.
366 -- So the binders of the first parallel group will be in scope in the second
367 -- group. But that's fine; there's no shadowing to worry about.
369 tcLcStmt m_tc ctxt (ParStmt bndr_stmts_s) elt_ty thing_inside
370 = do { (pairs', thing) <- loop bndr_stmts_s
371 ; return (ParStmt pairs', thing) }
373 -- loop :: [([LStmt Name], [Name])] -> TcM ([([LStmt TcId], [TcId])], thing)
374 loop [] = do { thing <- thing_inside elt_ty -- No refinement from pattern
375 ; return ([], thing) } -- matching in the branches
377 loop ((stmts, names) : pairs)
378 = do { (stmts', (ids, pairs', thing))
379 <- tcStmts ctxt (tcLcStmt m_tc) stmts elt_ty $ \ elt_ty' ->
380 do { ids <- tcLookupLocalIds names
381 ; (pairs', thing) <- loop pairs
382 ; return (ids, pairs', thing) }
383 ; return ( (stmts', ids) : pairs', thing ) }
385 tcLcStmt m_tc ctxt stmt elt_ty thing_inside
386 = pprPanic "tcLcStmt: unexpected Stmt" (ppr stmt)
388 --------------------------------
390 -- The main excitement here is dealing with rebindable syntax
392 tcDoStmt :: TcType -- Monad type, m
395 tcDoStmt m_ty ctxt (BindStmt pat rhs bind_op fail_op) reft_res_ty@(_,res_ty) thing_inside
396 = do { (rhs', pat_ty) <- withBox liftedTypeKind $ \ pat_ty ->
397 tcMonoExpr rhs (mkAppTy m_ty pat_ty)
398 -- We should use type *inference* for the RHS computations, becuase of GADTs.
399 -- do { pat <- rhs; <rest> }
401 -- case rhs of { pat -> <rest> }
402 -- We do inference on rhs, so that information about its type can be refined
403 -- when type-checking the pattern.
405 ; (pat', thing) <- tcLamPat pat pat_ty reft_res_ty thing_inside
407 -- Deal with rebindable syntax; (>>=) :: m a -> (a -> m b) -> m b
408 ; let bind_ty = mkFunTys [mkAppTy m_ty pat_ty,
409 mkFunTy pat_ty res_ty] res_ty
410 ; bind_op' <- tcSyntaxOp DoOrigin bind_op bind_ty
411 -- If (but only if) the pattern can fail,
412 -- typecheck the 'fail' operator
413 ; fail_op' <- if isIrrefutableHsPat pat'
414 then return noSyntaxExpr
415 else tcSyntaxOp DoOrigin fail_op (mkFunTy stringTy res_ty)
416 ; return (BindStmt pat' rhs' bind_op' fail_op', thing) }
419 tcDoStmt m_ty ctxt (ExprStmt rhs then_op _) reft_res_ty@(_,res_ty) thing_inside
420 = do { -- Deal with rebindable syntax; (>>) :: m a -> m b -> m b
421 a_ty <- newFlexiTyVarTy liftedTypeKind
422 ; let rhs_ty = mkAppTy m_ty a_ty
423 then_ty = mkFunTys [rhs_ty, res_ty] res_ty
424 ; then_op' <- tcSyntaxOp DoOrigin then_op then_ty
425 ; rhs' <- tcPolyExpr rhs rhs_ty
426 ; thing <- thing_inside reft_res_ty
427 ; return (ExprStmt rhs' then_op' rhs_ty, thing) }
429 tcDoStmt m_ty ctxt stmt res_ty thing_inside
430 = pprPanic "tcDoStmt: unexpected Stmt" (ppr stmt)
432 --------------------------------
434 -- The distinctive features here are
436 -- (b) no rebindable syntax
438 tcMDoStmt :: (LHsExpr Name -> TcM (LHsExpr TcId, TcType)) -- RHS inference
440 tcMDoStmt tc_rhs ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
441 = do { (rhs', pat_ty) <- tc_rhs rhs
442 ; (pat', thing) <- tcLamPat pat pat_ty res_ty thing_inside
443 ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
445 tcMDoStmt tc_rhs ctxt (ExprStmt rhs then_op _) res_ty thing_inside
446 = do { (rhs', elt_ty) <- tc_rhs rhs
447 ; thing <- thing_inside res_ty
448 ; return (ExprStmt rhs' noSyntaxExpr elt_ty, thing) }
450 tcMDoStmt tc_rhs ctxt (RecStmt stmts laterNames recNames _ _) res_ty thing_inside
451 = do { rec_tys <- newFlexiTyVarTys (length recNames) liftedTypeKind
452 ; let rec_ids = zipWith mkLocalId recNames rec_tys
453 ; tcExtendIdEnv rec_ids $ do
454 { (stmts', (later_ids, rec_rets))
455 <- tcStmts ctxt (tcMDoStmt tc_rhs) stmts res_ty $ \ res_ty' ->
456 -- ToDo: res_ty not really right
457 do { rec_rets <- zipWithM tc_ret recNames rec_tys
458 ; later_ids <- tcLookupLocalIds laterNames
459 ; return (later_ids, rec_rets) }
461 ; (thing,lie) <- tcExtendIdEnv later_ids (getLIE (thing_inside res_ty))
462 -- NB: The rec_ids for the recursive things
463 -- already scope over this part. This binding may shadow
464 -- some of them with polymorphic things with the same Name
465 -- (see note [RecStmt] in HsExpr)
466 ; lie_binds <- bindInstsOfLocalFuns lie later_ids
468 ; return (RecStmt stmts' later_ids rec_ids rec_rets lie_binds, thing)
471 -- Unify the types of the "final" Ids with those of "knot-tied" Ids
472 tc_ret rec_name mono_ty
473 = do { poly_id <- tcLookupId rec_name
474 -- poly_id may have a polymorphic type
475 -- but mono_ty is just a monomorphic type variable
476 ; co_fn <- tcSubExp (idType poly_id) mono_ty
477 ; return (mkHsWrap co_fn (HsVar poly_id)) }
479 tcMDoStmt tc_rhs ctxt stmt res_ty thing_inside
480 = pprPanic "tcMDoStmt: unexpected Stmt" (ppr stmt)
485 %************************************************************************
487 \subsection{Errors and contexts}
489 %************************************************************************
491 @sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same
492 number of args are used in each equation.
495 checkArgs :: Name -> MatchGroup Name -> TcM ()
496 checkArgs fun (MatchGroup (match1:matches) _)
497 | null bad_matches = return ()
499 = failWithTc (vcat [ptext SLIT("Equations for") <+> quotes (ppr fun) <+>
500 ptext SLIT("have different numbers of arguments"),
501 nest 2 (ppr (getLoc match1)),
502 nest 2 (ppr (getLoc (head bad_matches)))])
504 n_args1 = args_in_match match1
505 bad_matches = [m | m <- matches, args_in_match m /= n_args1]
507 args_in_match :: LMatch Name -> Int
508 args_in_match (L _ (Match pats _ _)) = length pats
509 checkArgs fun other = panic "TcPat.checkArgs" -- Matches always non-empty
513 matchCtxt ctxt match = hang (ptext SLIT("In") <+> pprMatchContext ctxt <> colon)
514 4 (pprMatch ctxt match)
516 stmtCtxt ctxt stmt = hang (ptext SLIT("In") <+> pprStmtContext ctxt <> colon)