- 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
- -> Expected TcRhoType
- -> TcM TcGRHSs
-
- -- 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 [GRHS [ResultStmt rhs loc1] loc2] binds _) exp_ty
- = tcBindsAndThen glue_on binds $
- tcMonoExpr rhs exp_ty `thenM` \ rhs' ->
- readExpectedType exp_ty `thenM` \ exp_ty' ->
- returnM (GRHSs [GRHS [ResultStmt rhs' loc1] loc2] EmptyBinds exp_ty')
-
-tcGRHSs ctxt (GRHSs grhss binds _) exp_ty
- = tcBindsAndThen glue_on binds $
- zapExpectedType exp_ty `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
- tc_grhs (GRHS guarded locn)
- = addSrcLoc locn $
- tcStmts (PatGuard ctxt) m_ty guarded `thenM` \ guarded' ->
- returnM (GRHS guarded' locn)
-
- m_ty = (\ty -> ty, exp_ty')
- in
- mappM tc_grhs grhss `thenM` \ grhss' ->
- returnM (GRHSs grhss' EmptyBinds 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
- :: [RenamedPat] -> Expected TcRhoType
- -> (Expected TcRhoType -> 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
- readExpectedType expected_ty `thenM` \ exp_ty ->
- tcCheckExistentialPat ex_tvs ex_ids ex_lie lie_req exp_ty `thenM` \ ex_binds ->
- -- NB: we *must* pass "exp_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
- in
- tcExtendLocalValEnv2 xve $
- tc_match_pats pats rest_ty 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
- -> TcType -- and type of the Match; vars in here must not escape
- -> TcM TcDictBinds -- LIE to float out and dict bindings
-tcCheckExistentialPat ex_tvs ex_ids ex_lie lie_req match_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 EmptyMonoBinds
-
- | otherwise
- = addErrCtxtM (sigPatCtxt tv_list ex_ids match_ty) $
-
- -- 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 ->
- checkSigTyVarsWrt (tyVarsOfType match_ty) tv_list `thenM_`
-
- returnM (dict_binds `AndMonoBinds` inst_binds)
- where
- doc = text ("existential context of a data constructor")
- tv_list = bagToList ex_tvs
- not_overloaded id = not (isOverloadedTy (idType id))