import HsSyn ( HsBinds(..), Match(..), GRHSs(..), GRHS(..),
MonoBinds(..), StmtCtxt(..), Stmt(..),
- pprMatch, getMatchLoc
+ pprMatch, getMatchLoc, consLetStmt,
+ mkMonoBind
)
import RnHsSyn ( RenamedMatch, RenamedGRHSs, RenamedStmt )
import TcHsSyn ( TcMatch, TcGRHSs, TcStmt )
import TcMonad
-import TcMonoType ( checkSigTyVars, tcHsTyVar, tcHsType, sigPatCtxt )
+import TcMonoType ( checkSigTyVars, tcHsTyVar, tcHsSigType, sigPatCtxt )
import Inst ( Inst, LIE, plusLIE, emptyLIE, plusLIEs )
-import TcEnv ( tcExtendLocalValEnv, tcExtendGlobalTyVars, tcExtendTyVarEnv )
+import TcEnv ( tcExtendLocalValEnv, tcExtendGlobalTyVars, tcExtendTyVarEnv, tcGetGlobalTyVars )
import TcPat ( tcPat, tcPatBndr_NoSigs, polyPatSig )
-import TcType ( TcType, newTyVarTy, newTyVarTy_OpenKind )
+import TcType ( TcType, newTyVarTy, newTyVarTy_OpenKind, zonkTcTyVars )
import TcBinds ( tcBindsAndThen )
import TcSimplify ( tcSimplifyAndCheck, bindInstsOfLocalFuns )
import TcUnify ( unifyFunTy, unifyTauTy )
returnTc match_and_lie
else
- -- If there are sig tve we must be careful *not* to use
+ -- If there are sig tvs we must be careful *not* to use
-- expected_ty right away, else we'll unify with tyvars free
-- in the envt. So invent a fresh tyvar and use that instead
newTyVarTy_OpenKind `thenNF_Tc` \ tyvar_ty ->
-- Check that the scoped type variables from the patterns
-- have not been constrained
tcAddErrCtxtM (sigPatCtxt sig_tyvars pat_ids) (
- checkSigTyVars sig_tyvars
+ checkSigTyVars sig_tyvars emptyVarSet
) `thenTc_`
-- *Now* we're free to unify with expected_ty
returnTc match_and_lie
where
- tc_match expexted_ty -- Any sig tyvars are in scope by now
+ tc_match expected_ty -- Any sig tyvars are in scope by now
= -- STEP 1: Typecheck the patterns
tcMatchPats pats expected_ty `thenTc` \ (rhs_ty, pats', lie_req1, ex_tvs, pat_bndrs, lie_avail) ->
let
-- STEP 3: Unify with the rhs type signature if any
(case maybe_rhs_sig of
Nothing -> returnTc ()
- Just sig -> tcHsType sig `thenTc` \ sig_ty ->
+ Just sig -> tcHsSigType sig `thenTc` \ sig_ty ->
-- Check that the signature isn't a polymorphic one, which
-- we don't permit (at present, anyway)
-- STEP 5: Check for existentially bound type variables
tcExtendGlobalTyVars (tyVarsOfType rhs_ty) (
tcAddErrCtxtM (sigPatCtxt ex_tv_list pat_ids) $
- checkSigTyVars ex_tv_list `thenTc` \ zonked_ex_tvs ->
+ checkSigTyVars ex_tv_list emptyVarSet `thenTc` \ zonked_ex_tvs ->
tcSimplifyAndCheck
(text ("the existential context of a data constructor"))
(mkVarSet zonked_ex_tvs)
-- glue_on just avoids stupid dross
glue_on _ EmptyMonoBinds grhss = grhss -- The common case
glue_on is_rec mbinds (GRHSs grhss binds ty)
- = GRHSs grhss (MonoBind mbinds [] is_rec `ThenBinds` binds) ty
+ = GRHSs grhss (mkMonoBind mbinds [] is_rec `ThenBinds` binds) ty
tcGRHSs :: RenamedGRHSs
-> TcType -> StmtCtxt
tcExtendGlobalTyVars (tyVarsOfType (m elt_ty)) $
tcAddErrCtxtM (sigPatCtxt pat_tv_list pat_ids) $
- checkSigTyVars pat_tv_list `thenTc` \ zonked_pat_tvs ->
+ checkSigTyVars pat_tv_list emptyVarSet `thenTc` \ zonked_pat_tvs ->
tcSimplifyAndCheck
(text ("the existential context of a data constructor"))
lie_avail stmts_lie `thenTc` \ (final_lie, dict_binds) ->
returnTc (BindStmt pat' exp' src_loc :
- LetStmt (MonoBind dict_binds [] Recursive) :
- stmts',
+ consLetStmt (mkMonoBind dict_binds [] Recursive) stmts',
lie_req `plusLIE` final_lie)
tcStmts do_or_lc m (LetStmt binds : stmts) elt_ty
binds
(tcStmts do_or_lc m stmts elt_ty)
where
- combine is_rec binds' stmts' = LetStmt (MonoBind binds' [] is_rec) : stmts'
+ combine is_rec binds' stmts' = consLetStmt (mkMonoBind binds' [] is_rec) stmts'
isDoStmt DoStmt = True
where
what = case do_or_lc of
ListComp -> ptext SLIT("a list-comprehension qualifier")
- DoStmt -> ptext SLIT("a do statement:")
+ DoStmt -> ptext SLIT("a do statement")
PatBindRhs -> thing <+> ptext SLIT("a pattern binding")
FunRhs f -> thing <+> ptext SLIT("an equation for") <+> quotes (ppr f)
CaseAlt -> thing <+> ptext SLIT("a case alternative")