- -> TcM s (TcMatch s,LIE s) -- NB No type returned, because it was passed
- -- in instead!
-
-tcMatchExpected expected_ty the_match@(PatMatch pat match)
- = case getFunTy_maybe expected_ty of
-
- Nothing -> -- Not a function type (eg type variable)
- -- So use tcMatch instead
- tcMatch the_match `thenTc` \ (match', lie_match, match_ty) ->
- unifyTauTy match_ty expected_ty `thenTc_`
- returnTc (match', lie_match)
-
- Just (arg_ty,rest_ty) -> -- It's a function type!
- let binders = collectPatBinders pat
- in
- newMonoIds binders mkTypeKind (\ _ ->
- tcPat pat `thenTc` \ (pat', lie_pat, pat_ty) ->
- unifyTauTy arg_ty pat_ty `thenTc_`
- tcMatchExpected rest_ty match `thenTc` \ (match', lie_match) ->
- returnTc (PatMatch pat' match',
- plusLIE lie_pat lie_match)
- )
-
-tcMatchExpected expected_ty (GRHSMatch grhss_and_binds)
- = tcGRHSsAndBinds grhss_and_binds `thenTc` \ (grhss_and_binds', lie, grhss_ty) ->
- unifyTauTy grhss_ty expected_ty `thenTc_`
- returnTc (GRHSMatch grhss_and_binds', lie)
-
-tcMatch :: RenamedMatch -> TcM s (TcMatch s, LIE s, TcType s)
-
-tcMatch (PatMatch pat match)
- = let binders = collectPatBinders pat
+ -> TcType -- Expected result-type of the Match.
+ -- Early unification with this guy gives better error messages
+ -- We regard the Match as having type
+ -- (ty1 -> ... -> tyn -> result_ty)
+ -- where there are n patterns.
+ -> TcM TcMatch
+
+tcMatch xve1 ctxt match@(Match pats maybe_rhs_sig grhss) expected_ty
+ = addSrcLoc (getMatchLoc match) $ -- At one stage I removed this;
+ addErrCtxt (matchCtxt ctxt match) $ -- I'm not sure why, so I put it back
+ tcMatchPats pats expected_ty tc_grhss `thenM` \ (pats', grhss', ex_binds) ->
+ returnM (Match pats' Nothing (glue_on ex_binds grhss'))
+
+ where
+ tc_grhss rhs_ty
+ = tcExtendLocalValEnv2 xve1 $
+
+ -- Deal with the result signature
+ case maybe_rhs_sig of
+ Nothing -> tcGRHSs ctxt grhss rhs_ty
+
+ Just sig -> tcAddScopedTyVars [sig] $
+ -- Bring into scope the type variables in the signature
+ tcHsSigType ResSigCtxt sig `thenM` \ sig_ty ->
+ tcGRHSs ctxt grhss sig_ty `thenM` \ grhss' ->
+ tcSubExp rhs_ty sig_ty `thenM` \ co_fn ->
+ returnM (lift_grhss co_fn rhs_ty grhss')
+
+-- lift_grhss pushes the coercion down to the right hand sides,
+-- because there is no convenient place to hang it otherwise.
+lift_grhss co_fn rhs_ty grhss
+ | isIdCoercion co_fn = grhss
+lift_grhss co_fn rhs_ty (GRHSs grhss binds ty)
+ = GRHSs (map lift_grhs grhss) binds rhs_ty -- Change the type, since we
+ where
+ lift_grhs (GRHS stmts loc) = GRHS (map lift_stmt stmts) loc
+
+ lift_stmt (ResultStmt e l) = ResultStmt (co_fn <$> e) l
+ lift_stmt stmt = stmt
+
+-- glue_on just avoids stupid dross
+glue_on EmptyBinds grhss = grhss -- The common case
+glue_on binds1 (GRHSs grhss binds2 ty)
+ = GRHSs grhss (binds1 `ThenBinds` binds2) ty
+
+
+tcGRHSs :: RenamedMatchContext -> RenamedGRHSs
+ -> TcType
+ -> TcM TcGRHSs
+
+tcGRHSs ctxt (GRHSs grhss binds _) expected_ty
+ = tcBindsAndThen glue_on binds (tc_grhss grhss)
+ where
+ m_ty = (\ty -> ty, expected_ty)
+
+ tc_grhss grhss
+ = mappM tc_grhs grhss `thenM` \ grhss' ->
+ returnM (GRHSs grhss' EmptyBinds expected_ty)
+
+ tc_grhs (GRHS guarded locn)
+ = addSrcLoc locn $
+ tcStmts (PatGuard ctxt) m_ty guarded `thenM` \ guarded' ->
+ returnM (GRHS guarded' locn)
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{tcMatchPats}
+%* *
+%************************************************************************
+
+\begin{code}
+tcMatchPats
+ :: [RenamedPat] -> TcType
+ -> (TcType -> TcM a)
+ -> TcM ([TcPat], a, TcHsBinds)
+-- 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 expected_ty thing_inside
+ = -- STEP 1: Bring pattern-signature type variables into scope
+ tcAddScopedTyVars (collectSigTysFromPats pats) (
+
+ -- STEP 2: Typecheck the patterns themselves, gathering all the stuff
+ -- then do the thing inside
+ getLIE (tc_match_pats pats expected_ty 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 expected_ty `thenM` \ ex_binds ->
+ -- NB: we *must* pass "expected_ty" not "result_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 (a -> Int).
+
+ returnM (pats', result, mkMonoBind Recursive ex_binds)
+
+tc_match_pats [] expected_ty thing_inside
+ = thing_inside expected_ty `thenM` \ answer ->
+ returnM ([], emptyBag, [], [], answer)
+
+tc_match_pats (pat:pats) expected_ty thing_inside
+ = subFunTy expected_ty $ \ arg_ty rest_ty ->
+ -- This is the unique place we call subFunTy
+ -- The point is that if expected_y is a "hole", we want
+ -- to make arg_ty and rest_ty as "holes" too.
+ tcPat tcMonoPatBndr pat arg_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