- lift_grhs (GRHS stmts) = GRHS (map lift_stmt stmts)
-
- lift_stmt (L loc (ResultStmt e)) = L loc (ResultStmt (fmap (co_fn <$>) e))
- lift_stmt stmt = stmt
-
-tcGRHSs :: TcMatchCtxt -> GRHSs Name
- -> Expected TcRhoType
- -> TcM (GRHSs TcId)
-
- -- Special case when there is just one equation with a degenerate
- -- guard; then we pass in the full Expected type, so that we get
- -- good inference from simple things like
- -- f = \(x::forall a.a->a) -> <stuff>
- -- This is a consequence of the fact that tcStmts takes a TcType,
- -- not a Expected TcType, a decision we could revisit if necessary
-tcGRHSs ctxt (GRHSs [L loc1 (GRHS [L loc2 (ResultStmt rhs)])] binds _) exp_ty
- = tcBindsAndThen glueBindsOnGRHSs binds $
- mc_body ctxt rhs exp_ty `thenM` \ rhs' ->
- readExpectedType exp_ty `thenM` \ exp_ty' ->
- returnM (GRHSs [L loc1 (GRHS [L loc2 (ResultStmt rhs')])] [] exp_ty')
-
-tcGRHSs ctxt (GRHSs grhss binds _) exp_ty
- = tcBindsAndThen glueBindsOnGRHSs binds $
- zapExpectedType exp_ty openTypeKind `thenM` \ exp_ty' ->
- -- Even if there is only one guard, we zap the RHS type to
- -- a monotype. Reason: it makes tcStmts much easier,
- -- and even a one-armed guard has a notional second arm
- let
- stmt_ctxt = SC { sc_what = PatGuard (mc_what ctxt),
- sc_rhs = tcCheckRho,
- sc_body = sc_body,
- sc_ty = exp_ty' }
- sc_body body = mc_body ctxt body (Check exp_ty')
-
- tc_grhs (GRHS guarded)
- = tcStmts stmt_ctxt guarded `thenM` \ guarded' ->
- returnM (GRHS guarded')
- in
- mappM (wrapLocM tc_grhs) grhss `thenM` \ grhss' ->
- returnM (GRHSs grhss' [] exp_ty')
-\end{code}
-
-
-\begin{code}
-tcThingWithSig :: TcSigmaType -- Type signature
- -> (TcRhoType -> TcM r) -- How to type check the thing inside
- -> Expected TcRhoType -- Overall expected result type
- -> TcM (ExprCoFn, r)
--- Used for expressions with a type signature, and for result type signatures
-
-tcThingWithSig sig_ty thing_inside res_ty
- | not (isSigmaTy sig_ty)
- = thing_inside sig_ty `thenM` \ result ->
- tcSubExp res_ty sig_ty `thenM` \ co_fn ->
- returnM (co_fn, result)
-
- | otherwise -- The signature has some outer foralls
- = -- Must instantiate the outer for-alls of sig_tc_ty
- -- else we risk instantiating a ? res_ty to a forall-type
- -- which breaks the invariant that tcMonoExpr only returns phi-types
- tcGen sig_ty emptyVarSet thing_inside `thenM` \ (gen_fn, result) ->
- tcInstCall SignatureOrigin sig_ty `thenM` \ (inst_fn, inst_sig_ty) ->
- tcSubExp res_ty inst_sig_ty `thenM` \ co_fn ->
- returnM (co_fn <.> inst_fn <.> gen_fn, result)
- -- Note that we generalise, then instantiate. Ah well.
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{tcMatchPats}
-%* *
-%************************************************************************
-
-\begin{code}
-tcMatchPats
- :: [(LPat Name, Expected TcRhoType)]
- -> Expected TcRhoType
- -> TcM a
- -> TcM ([LPat TcId], a, HsBindGroup TcId)
--- Typecheck the patterns, extend the environment to bind the variables,
--- do the thing inside, use any existentially-bound dictionaries to
--- discharge parts of the returning LIE, and deal with pattern type
--- signatures
-
-tcMatchPats pats_w_tys body_ty thing_inside
- = -- STEP 1: Bring pattern-signature type variables into scope
- tcAddScopedTyVars (collectSigTysFromPats (map fst pats_w_tys)) (
-
- -- STEP 2: Typecheck the patterns themselves, gathering all the stuff
- -- then do the thing inside
- getLIE (tc_match_pats pats_w_tys thing_inside)
-
- ) `thenM` \ ((pats', ex_tvs, ex_ids, ex_lie, result), lie_req) ->
-
- -- STEP 4: Check for existentially bound type variables
- -- Do this *outside* the scope of the tcAddScopedTyVars, else checkSigTyVars
- -- complains that 'a' is captured by the inscope 'a'! (Test (d) in checkSigTyVars.)
- --
- -- I'm a bit concerned that lie_req1 from an 'inner' pattern in the list
- -- might need (via lie_req2) something made available from an 'outer'
- -- pattern. But it's inconvenient to deal with, and I can't find an example
- tcCheckExistentialPat ex_tvs ex_ids ex_lie lie_req
- pats_w_tys body_ty `thenM` \ ex_binds ->
- -- NB: we *must* pass "pats_w_tys" not just "body_ty" to tcCheckExistentialPat
- -- For example, we must reject this program:
- -- data C = forall a. C (a -> Int)
- -- f (C g) x = g x
- -- Here, result_ty will be simply Int, but expected_ty is (C -> a -> Int).
-
- returnM (pats', result, HsBindGroup ex_binds [] Recursive)
-
-tc_match_pats [] thing_inside
- = thing_inside `thenM` \ answer ->
- returnM ([], emptyBag, [], [], answer)
-
-tc_match_pats ((pat,pat_ty):pats) thing_inside
- = tcPat tcMonoPatBndr pat pat_ty `thenM` \ (pat', ex_tvs, pat_bndrs, ex_lie) ->
- let
- xve = bagToList pat_bndrs
- ex_ids = [id | (_, id) <- xve]
- -- ex_ids is all the pattern-bound Ids, a superset
- -- of the existential Ids used in checkExistentialPat
- in
- tcExtendLocalValEnv2 xve $
- traceTc (text "tc_match_pats" <+> (ppr xve $$ ppr (map (idType . snd) xve) $$
- ppr (map (typeKind . idType . snd) xve))) `thenM_`
- tc_match_pats pats thing_inside `thenM` \ (pats', exs_tvs, exs_ids, exs_lie, answer) ->
- returnM ( pat':pats',
- ex_tvs `unionBags` exs_tvs,
- ex_ids ++ exs_ids,
- ex_lie ++ exs_lie,
- answer
- )
-
-
-tcCheckExistentialPat :: Bag TcTyVar -- Existentially quantified tyvars bound by pattern
- -> [TcId] -- Ids bound by this pattern; used
- -- (a) by bindsInstsOfLocalFuns
- -- (b) to generate helpful error messages
- -> [Inst] -- and context
- -> [Inst] -- Required context
- -> [(pat,Expected TcRhoType)] -- Types of the patterns
- -> Expected TcRhoType -- Type of the body of the match
- -- Tyvars in either of these must not escape
- -> TcM TcDictBinds -- LIE to float out and dict bindings
-tcCheckExistentialPat ex_tvs ex_ids ex_lie lie_req pats_w_tys body_ty
- | isEmptyBag ex_tvs && all not_overloaded ex_ids
- -- Short cut for case when there are no existentials
- -- and no polymorphic overloaded variables
- -- e.g. f :: (forall a. Ord a => a -> a) -> Int -> Int
- -- f op x = ....
- -- Here we must discharge op Methods
- = ASSERT( null ex_lie )
- extendLIEs lie_req `thenM_`
- returnM emptyBag
-
- | otherwise
- = -- Read the by-now-filled-in expected types
- mapM readExpectedType (body_ty : map snd pats_w_tys) `thenM` \ tys ->
- addErrCtxtM (sigPatCtxt tv_list ex_ids tys) $
-
- -- In case there are any polymorpic, overloaded binders in the pattern
- -- (which can happen in the case of rank-2 type signatures, or data constructors
- -- with polymorphic arguments), we must do a bindInstsOfLocalFns here
- getLIE (bindInstsOfLocalFuns lie_req ex_ids) `thenM` \ (inst_binds, lie) ->
-
- -- Deal with overloaded functions bound by the pattern
- tcSimplifyCheck doc tv_list ex_lie lie `thenM` \ dict_binds ->
-
- -- Check for type variable escape
- checkSigTyVarsWrt (tyVarsOfTypes tys) tv_list `thenM_`
-
- returnM (dict_binds `unionBags` inst_binds)
+ tc_match ctxt pat_tys rhs_ty match@(Match pats maybe_rhs_sig grhss)
+ = addErrCtxt (matchCtxt (mc_what ctxt) match) $
+ do { (pats', grhss') <- tcPats LamPat pats pat_tys rhs_ty $
+ tc_grhss ctxt maybe_rhs_sig grhss
+ ; returnM (Match pats' Nothing grhss') }
+
+ tc_grhss ctxt Nothing grhss rhs_ty
+ = tcGRHSs ctxt grhss rhs_ty -- No result signature
+
+ tc_grhss ctxt (Just res_sig) grhss rhs_ty
+ = do { (inner_ty, sig_tvs) <- tcPatSig ResSigCtxt res_sig rhs_ty
+ ; tcExtendTyVarEnv2 sig_tvs $
+ tcGRHSs ctxt grhss inner_ty }
+
+-------------
+tcGRHSs :: TcMatchCtxt -> GRHSs Name -> BoxyRhoType -> TcM (GRHSs TcId)
+
+-- Notice that we pass in the full res_ty, so that we get
+-- good inference from simple things like
+-- f = \(x::forall a.a->a) -> <stuff>
+-- We used to force it to be a monotype when there was more than one guard
+-- but we don't need to do that any more
+
+tcGRHSs ctxt (GRHSs grhss binds) res_ty
+ = do { (binds', grhss') <- tcLocalBinds binds $
+ mappM (wrapLocM (tcGRHS ctxt res_ty)) grhss
+
+ ; returnM (GRHSs grhss' binds') }
+
+-------------
+tcGRHS :: TcMatchCtxt -> BoxyRhoType -> GRHS Name -> TcM (GRHS TcId)
+
+tcGRHS ctxt res_ty (GRHS guards rhs)
+ = do { (guards', rhs') <- tcStmts stmt_ctxt tcGuardStmt guards res_ty $
+ mc_body ctxt rhs
+ ; return (GRHS guards' rhs') }