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,
11 tcStmts, tcDoStmts, tcBody,
12 tcDoStmt, tcMDoStmt, tcGuardStmt
15 import {-# SOURCE #-} TcExpr( tcSyntaxOp, tcInferRho, tcMonoExpr, tcPolyExpr )
41 %************************************************************************
43 \subsection{tcMatchesFun, tcMatchesCase}
45 %************************************************************************
47 @tcMatchesFun@ typechecks a @[Match]@ list which occurs in a
48 @FunMonoBind@. The second argument is the name of the function, which
49 is used in error messages. It checks that all the equations have the
50 same number of arguments before using @tcMatches@ to do the work.
53 tcMatchesFun :: Name -> Bool
55 -> BoxyRhoType -- Expected type of function
56 -> TcM (HsWrapper, MatchGroup TcId) -- Returns type of body
58 tcMatchesFun fun_name inf matches exp_ty
59 = do { -- Check that they all have the same no of arguments
60 -- Location is in the monad, set the caller so that
61 -- any inter-equation error messages get some vaguely
62 -- sensible location. Note: we have to do this odd
63 -- ann-grabbing, because we don't always have annotations in
64 -- hand when we call tcMatchesFun...
65 checkArgs fun_name matches
67 -- ToDo: Don't use "expected" stuff if there ain't a type signature
68 -- because inconsistency between branches
69 -- may show up as something wrong with the (non-existent) type signature
71 -- This is one of two places places we call subFunTys
72 -- The point is that if expected_y is a "hole", we want
73 -- to make pat_tys and rhs_ty as "holes" too.
74 ; subFunTys doc n_pats exp_ty $ \ pat_tys rhs_ty ->
75 tcMatches match_ctxt pat_tys rhs_ty matches
78 doc = ptext (sLit "The equation(s) for") <+> quotes (ppr fun_name)
79 <+> ptext (sLit "have") <+> speakNOf n_pats (ptext (sLit "argument"))
80 n_pats = matchGroupArity matches
81 match_ctxt = MC { mc_what = FunRhs fun_name inf, mc_body = tcBody }
84 @tcMatchesCase@ doesn't do the argument-count check because the
85 parser guarantees that each equation has exactly one argument.
88 tcMatchesCase :: TcMatchCtxt -- Case context
89 -> TcRhoType -- Type of scrutinee
90 -> MatchGroup Name -- The case alternatives
91 -> BoxyRhoType -- Type of whole case expressions
92 -> TcM (MatchGroup TcId) -- Translated alternatives
94 tcMatchesCase ctxt scrut_ty matches res_ty
95 = tcMatches ctxt [scrut_ty] res_ty matches
97 tcMatchLambda :: MatchGroup Name -> BoxyRhoType -> TcM (HsWrapper, MatchGroup TcId)
98 tcMatchLambda match res_ty
99 = subFunTys doc n_pats res_ty $ \ pat_tys rhs_ty ->
100 tcMatches match_ctxt pat_tys rhs_ty match
102 n_pats = matchGroupArity match
103 doc = sep [ ptext (sLit "The lambda expression")
104 <+> quotes (pprSetDepth 1 $ pprMatches (LambdaExpr :: HsMatchContext Name) match),
105 -- The pprSetDepth makes the abstraction print briefly
106 ptext (sLit "has") <+> speakNOf n_pats (ptext (sLit "argument"))]
107 match_ctxt = MC { mc_what = LambdaExpr,
111 @tcGRHSsPat@ typechecks @[GRHSs]@ that occur in a @PatMonoBind@.
114 tcGRHSsPat :: GRHSs Name -> BoxyRhoType -> TcM (GRHSs TcId)
115 -- Used for pattern bindings
116 tcGRHSsPat grhss res_ty = tcGRHSs match_ctxt grhss res_ty
118 match_ctxt = MC { mc_what = PatBindRhs,
123 %************************************************************************
127 %************************************************************************
130 tcMatches :: TcMatchCtxt
131 -> [BoxySigmaType] -- Expected pattern types
132 -> BoxyRhoType -- Expected result-type of the Match.
134 -> TcM (MatchGroup TcId)
136 data TcMatchCtxt -- c.f. TcStmtCtxt, also in this module
137 = MC { mc_what :: HsMatchContext Name, -- What kind of thing this is
138 mc_body :: LHsExpr Name -- Type checker for a body of
141 -> TcM (LHsExpr TcId) }
143 tcMatches ctxt pat_tys rhs_ty (MatchGroup matches _)
144 = do { matches' <- mapM (tcMatch ctxt pat_tys rhs_ty) matches
145 ; return (MatchGroup matches' (mkFunTys pat_tys rhs_ty)) }
148 tcMatch :: TcMatchCtxt
149 -> [BoxySigmaType] -- Expected pattern types
150 -> BoxyRhoType -- Expected result-type of the Match.
154 tcMatch ctxt pat_tys rhs_ty match
155 = wrapLocM (tc_match ctxt pat_tys rhs_ty) match
157 tc_match ctxt pat_tys rhs_ty match@(Match pats maybe_rhs_sig grhss)
158 = add_match_ctxt match $
159 do { (pats', grhss') <- tcLamPats pats pat_tys rhs_ty $
160 tc_grhss ctxt maybe_rhs_sig grhss
161 ; return (Match pats' Nothing grhss') }
163 tc_grhss ctxt Nothing grhss rhs_ty
164 = tcGRHSs ctxt grhss rhs_ty -- No result signature
166 -- Result type sigs are no longer supported
167 tc_grhss _ (Just {}) _ _
168 = panic "tc_ghrss" -- Rejected by renamer
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 (pprMatchInCtxt m_ctxt match) thing_inside
178 tcGRHSs :: TcMatchCtxt -> GRHSs Name -> 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 mapM (wrapLocM (tcGRHS ctxt res_ty)) grhss
191 ; return (GRHSs grhss' binds') }
194 tcGRHS :: TcMatchCtxt -> 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, coi) <- boxySplitListTy res_ty
219 ; (stmts', body') <- tcStmts ListComp (tcLcStmt listTyCon) stmts
222 ; return $ mkHsWrapCoI coi
223 (HsDo ListComp stmts' body' (mkListTy elt_ty)) }
225 tcDoStmts PArrComp stmts body res_ty
226 = do { (elt_ty, coi) <- boxySplitPArrTy res_ty
227 ; (stmts', body') <- tcStmts PArrComp (tcLcStmt parrTyCon) stmts
230 ; return $ mkHsWrapCoI coi
231 (HsDo PArrComp stmts' body' (mkPArrTy elt_ty)) }
233 tcDoStmts DoExpr stmts body res_ty
234 = do { (stmts', body') <- tcStmts DoExpr tcDoStmt stmts
237 ; return (HsDo DoExpr stmts' body' res_ty) }
239 tcDoStmts ctxt@(MDoExpr _) stmts body res_ty
240 = do { ((m_ty, elt_ty), coi) <- 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
249 ; let names = [mfixName, bindMName, thenMName, returnMName, failMName]
250 ; insts <- mapM (newMethodFromName DoOrigin m_ty) names
253 (HsDo (MDoExpr (names `zip` insts)) stmts' body' res_ty') }
255 tcDoStmts ctxt _ _ _ = pprPanic "tcDoStmts" (pprStmtContext ctxt)
257 tcBody :: LHsExpr Name -> BoxyRhoType -> TcM (LHsExpr TcId)
259 = do { traceTc (text "tcBody" <+> ppr res_ty)
260 ; body' <- tcPolyExpr body res_ty
266 %************************************************************************
270 %************************************************************************
274 = forall thing. HsStmtContext Name
276 -> BoxyRhoType -- Result type for comprehension
277 -> (BoxyRhoType -> TcM thing) -- Checker for what follows the stmt
278 -> TcM (Stmt TcId, thing)
280 tcStmts :: HsStmtContext Name
281 -> TcStmtChecker -- NB: higher-rank type
284 -> (BoxyRhoType -> TcM thing)
285 -> TcM ([LStmt TcId], thing)
287 -- Note the higher-rank type. stmt_chk is applied at different
288 -- types in the equations for tcStmts
290 tcStmts _ _ [] res_ty thing_inside
291 = do { thing <- thing_inside res_ty
292 ; return ([], thing) }
294 -- LetStmts are handled uniformly, regardless of context
295 tcStmts ctxt stmt_chk (L loc (LetStmt binds) : stmts) res_ty thing_inside
296 = do { (binds', (stmts',thing)) <- tcLocalBinds binds $
297 tcStmts ctxt stmt_chk stmts res_ty thing_inside
298 ; return (L loc (LetStmt binds') : stmts', thing) }
300 -- For the vanilla case, handle the location-setting part
301 tcStmts ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside
302 = do { (stmt', (stmts', thing)) <-
304 addErrCtxt (pprStmtInCtxt ctxt stmt) $
305 stmt_chk ctxt stmt res_ty $ \ res_ty' ->
307 tcStmts ctxt stmt_chk stmts res_ty' $
309 ; return (L loc stmt' : stmts', thing) }
311 --------------------------------
313 tcGuardStmt :: TcStmtChecker
314 tcGuardStmt _ (ExprStmt guard _ _) res_ty thing_inside
315 = do { guard' <- tcMonoExpr guard boolTy
316 ; thing <- thing_inside res_ty
317 ; return (ExprStmt guard' noSyntaxExpr boolTy, thing) }
319 tcGuardStmt _ (BindStmt pat rhs _ _) res_ty thing_inside
320 = do { (rhs', rhs_ty) <- tcInferRho rhs
321 ; (pat', thing) <- tcLamPat pat rhs_ty res_ty thing_inside
322 ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
324 tcGuardStmt _ stmt _ _
325 = pprPanic "tcGuardStmt: unexpected Stmt" (ppr stmt)
328 --------------------------------
329 -- List comprehensions and PArrays
331 tcLcStmt :: TyCon -- The list/Parray type constructor ([] or PArray)
334 -- A generator, pat <- rhs
335 tcLcStmt m_tc _ (BindStmt pat rhs _ _) res_ty thing_inside
336 = do { (rhs', pat_ty) <- withBox liftedTypeKind $ \ ty ->
337 tcMonoExpr rhs (mkTyConApp m_tc [ty])
338 ; (pat', thing) <- tcLamPat pat pat_ty res_ty thing_inside
339 ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
342 tcLcStmt _ _ (ExprStmt rhs _ _) res_ty thing_inside
343 = do { rhs' <- tcMonoExpr rhs boolTy
344 ; thing <- thing_inside res_ty
345 ; return (ExprStmt rhs' noSyntaxExpr boolTy, thing) }
347 -- A parallel set of comprehensions
348 -- [ (g x, h x) | ... ; let g v = ...
349 -- | ... ; let h v = ... ]
351 -- It's possible that g,h are overloaded, so we need to feed the LIE from the
352 -- (g x, h x) up through both lots of bindings (so we get the bindInstsOfLocalFuns).
353 -- Similarly if we had an existential pattern match:
355 -- data T = forall a. Show a => C a
357 -- [ (show x, show y) | ... ; C x <- ...
358 -- | ... ; C y <- ... ]
360 -- Then we need the LIE from (show x, show y) to be simplified against
361 -- the bindings for x and y.
363 -- It's difficult to do this in parallel, so we rely on the renamer to
364 -- ensure that g,h and x,y don't duplicate, and simply grow the environment.
365 -- So the binders of the first parallel group will be in scope in the second
366 -- group. But that's fine; there's no shadowing to worry about.
368 tcLcStmt m_tc ctxt (ParStmt bndr_stmts_s) elt_ty thing_inside
369 = do { (pairs', thing) <- loop bndr_stmts_s
370 ; return (ParStmt pairs', thing) }
372 -- loop :: [([LStmt Name], [Name])] -> TcM ([([LStmt TcId], [TcId])], thing)
373 loop [] = do { thing <- thing_inside elt_ty
374 ; return ([], thing) } -- matching in the branches
376 loop ((stmts, names) : pairs)
377 = do { (stmts', (ids, pairs', thing))
378 <- tcStmts ctxt (tcLcStmt m_tc) stmts elt_ty $ \ _elt_ty' ->
379 do { ids <- tcLookupLocalIds names
380 ; (pairs', thing) <- loop pairs
381 ; return (ids, pairs', thing) }
382 ; return ( (stmts', ids) : pairs', thing ) }
384 tcLcStmt m_tc ctxt (TransformStmt (stmts, binders) usingExpr maybeByExpr) elt_ty thing_inside = do
385 (stmts', (binders', usingExpr', maybeByExpr', thing)) <-
386 tcStmts (TransformStmtCtxt ctxt) (tcLcStmt m_tc) stmts elt_ty $ \elt_ty' -> do
387 let alphaListTy = mkTyConApp m_tc [alphaTy]
389 (usingExpr', maybeByExpr') <-
392 -- We must validate that usingExpr :: forall a. [a] -> [a]
393 usingExpr' <- tcPolyExpr usingExpr (mkForAllTy alphaTyVar (alphaListTy `mkFunTy` alphaListTy))
394 return (usingExpr', Nothing)
396 -- We must infer a type such that e :: t and then check that usingExpr :: forall a. (a -> t) -> [a] -> [a]
397 (byExpr', tTy) <- tcInferRho byExpr
398 usingExpr' <- tcPolyExpr usingExpr (mkForAllTy alphaTyVar ((alphaTy `mkFunTy` tTy) `mkFunTy` (alphaListTy `mkFunTy` alphaListTy)))
399 return (usingExpr', Just byExpr')
401 binders' <- tcLookupLocalIds binders
402 thing <- thing_inside elt_ty'
404 return (binders', usingExpr', maybeByExpr', thing)
406 return (TransformStmt (stmts', binders') usingExpr' maybeByExpr', thing)
408 tcLcStmt m_tc ctxt (GroupStmt (stmts, bindersMap) groupByClause) elt_ty thing_inside = do
409 (stmts', (bindersMap', groupByClause', thing)) <-
410 tcStmts (TransformStmtCtxt ctxt) (tcLcStmt m_tc) stmts elt_ty $ \elt_ty' -> do
411 let alphaListTy = mkTyConApp m_tc [alphaTy]
412 alphaListListTy = mkTyConApp m_tc [alphaListTy]
415 case groupByClause of
416 GroupByNothing usingExpr ->
417 -- We must validate that usingExpr :: forall a. [a] -> [[a]]
418 tcPolyExpr usingExpr (mkForAllTy alphaTyVar (alphaListTy `mkFunTy` alphaListListTy)) >>= (return . GroupByNothing)
419 GroupBySomething eitherUsingExpr byExpr -> do
420 -- We must infer a type such that byExpr :: t
421 (byExpr', tTy) <- tcInferRho byExpr
423 -- If it exists, we then check that usingExpr :: forall a. (a -> t) -> [a] -> [[a]]
424 let expectedUsingType = mkForAllTy alphaTyVar ((alphaTy `mkFunTy` tTy) `mkFunTy` (alphaListTy `mkFunTy` alphaListListTy))
426 case eitherUsingExpr of
427 Left usingExpr -> (tcPolyExpr usingExpr expectedUsingType) >>= (return . Left)
428 Right usingExpr -> (tcPolyExpr (noLoc usingExpr) expectedUsingType) >>= (return . Right . unLoc)
429 return $ GroupBySomething eitherUsingExpr' byExpr'
431 -- Find the IDs and types of all old binders
432 let (oldBinders, newBinders) = unzip bindersMap
433 oldBinders' <- tcLookupLocalIds oldBinders
435 -- Ensure that every old binder of type b is linked up with its new binder which should have type [b]
436 let newBinders' = zipWith associateNewBinder oldBinders' newBinders
438 -- Type check the thing in the environment with these new binders and return the result
439 thing <- tcExtendIdEnv newBinders' (thing_inside elt_ty')
440 return (zipEqual "tcLcStmt: Old and new binder lists were not of the same length" oldBinders' newBinders', groupByClause', thing)
442 return (GroupStmt (stmts', bindersMap') groupByClause', thing)
444 associateNewBinder :: TcId -> Name -> TcId
445 associateNewBinder oldBinder newBinder = mkLocalId newBinder (mkTyConApp m_tc [idType oldBinder])
447 tcLcStmt _ _ stmt _ _
448 = pprPanic "tcLcStmt: unexpected Stmt" (ppr stmt)
450 --------------------------------
452 -- The main excitement here is dealing with rebindable syntax
454 tcDoStmt :: TcStmtChecker
456 tcDoStmt _ (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
457 = do { (rhs', rhs_ty) <- tcInferRho rhs
458 -- We should use type *inference* for the RHS computations,
460 -- do { pat <- rhs; <rest> }
462 -- case rhs of { pat -> <rest> }
463 -- We do inference on rhs, so that information about its type
464 -- can be refined when type-checking the pattern.
466 -- Deal with rebindable syntax:
467 -- (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty
468 -- This level of generality is needed for using do-notation
469 -- in full generality; see Trac #1537
470 ; ((bind_op', new_res_ty), pat_ty) <-
471 withBox liftedTypeKind $ \ pat_ty ->
472 withBox liftedTypeKind $ \ new_res_ty ->
473 tcSyntaxOp DoOrigin bind_op
474 (mkFunTys [rhs_ty, mkFunTy pat_ty new_res_ty] res_ty)
476 -- If (but only if) the pattern can fail,
477 -- typecheck the 'fail' operator
478 ; fail_op' <- if isIrrefutableHsPat pat
479 then return noSyntaxExpr
480 else tcSyntaxOp DoOrigin fail_op (mkFunTy stringTy new_res_ty)
482 ; (pat', thing) <- tcLamPat pat pat_ty new_res_ty thing_inside
484 ; return (BindStmt pat' rhs' bind_op' fail_op', thing) }
487 tcDoStmt _ (ExprStmt rhs then_op _) res_ty thing_inside
488 = do { (rhs', rhs_ty) <- tcInferRho rhs
490 -- Deal with rebindable syntax; (>>) :: rhs_ty -> new_res_ty -> res_ty
491 ; (then_op', new_res_ty) <-
492 withBox liftedTypeKind $ \ new_res_ty ->
493 tcSyntaxOp DoOrigin then_op
494 (mkFunTys [rhs_ty, new_res_ty] res_ty)
496 ; thing <- thing_inside new_res_ty
497 ; return (ExprStmt rhs' then_op' rhs_ty, thing) }
499 tcDoStmt ctxt (RecStmt {}) _ _
500 = failWithTc (ptext (sLit "Illegal 'rec' stmt in") <+> pprStmtContext ctxt)
501 -- This case can't be caught in the renamer
502 -- see RnExpr.checkRecStmt
505 = pprPanic "tcDoStmt: unexpected Stmt" (ppr stmt)
507 --------------------------------
509 -- The distinctive features here are
511 -- (b) no rebindable syntax
513 tcMDoStmt :: (LHsExpr Name -> TcM (LHsExpr TcId, TcType)) -- RHS inference
515 tcMDoStmt tc_rhs _ (BindStmt pat rhs _ _) res_ty thing_inside
516 = do { (rhs', pat_ty) <- tc_rhs rhs
517 ; (pat', thing) <- tcLamPat pat pat_ty res_ty thing_inside
518 ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
520 tcMDoStmt tc_rhs _ (ExprStmt rhs _ _) res_ty thing_inside
521 = do { (rhs', elt_ty) <- tc_rhs rhs
522 ; thing <- thing_inside res_ty
523 ; return (ExprStmt rhs' noSyntaxExpr elt_ty, thing) }
525 tcMDoStmt tc_rhs ctxt (RecStmt stmts laterNames recNames _ _) res_ty thing_inside
526 = do { rec_tys <- newFlexiTyVarTys (length recNames) liftedTypeKind
527 ; let rec_ids = zipWith mkLocalId recNames rec_tys
528 ; tcExtendIdEnv rec_ids $ do
529 { (stmts', (later_ids, rec_rets))
530 <- tcStmts ctxt (tcMDoStmt tc_rhs) stmts res_ty $ \ _res_ty' ->
531 -- ToDo: res_ty not really right
532 do { rec_rets <- zipWithM tc_ret recNames rec_tys
533 ; later_ids <- tcLookupLocalIds laterNames
534 ; return (later_ids, rec_rets) }
536 ; (thing,lie) <- tcExtendIdEnv later_ids (getLIE (thing_inside res_ty))
537 -- NB: The rec_ids for the recursive things
538 -- already scope over this part. This binding may shadow
539 -- some of them with polymorphic things with the same Name
540 -- (see note [RecStmt] in HsExpr)
541 ; lie_binds <- bindInstsOfLocalFuns lie later_ids
543 ; return (RecStmt stmts' later_ids rec_ids rec_rets lie_binds, thing)
546 -- Unify the types of the "final" Ids with those of "knot-tied" Ids
547 tc_ret rec_name mono_ty
548 = do { poly_id <- tcLookupId rec_name
549 -- poly_id may have a polymorphic type
550 -- but mono_ty is just a monomorphic type variable
551 ; co_fn <- tcSubExp DoOrigin (idType poly_id) mono_ty
552 ; return (mkHsWrap co_fn (HsVar poly_id)) }
554 tcMDoStmt _ _ stmt _ _
555 = pprPanic "tcMDoStmt: unexpected Stmt" (ppr stmt)
560 %************************************************************************
562 \subsection{Errors and contexts}
564 %************************************************************************
566 @sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same
567 number of args are used in each equation.
570 checkArgs :: Name -> MatchGroup Name -> TcM ()
571 checkArgs fun (MatchGroup (match1:matches) _)
572 | null bad_matches = return ()
574 = failWithTc (vcat [ptext (sLit "Equations for") <+> quotes (ppr fun) <+>
575 ptext (sLit "have different numbers of arguments"),
576 nest 2 (ppr (getLoc match1)),
577 nest 2 (ppr (getLoc (head bad_matches)))])
579 n_args1 = args_in_match match1
580 bad_matches = [m | m <- matches, args_in_match m /= n_args1]
582 args_in_match :: LMatch Name -> Int
583 args_in_match (L _ (Match pats _ _)) = length pats
584 checkArgs _ _ = panic "TcPat.checkArgs" -- Matches always non-empty