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, noSigs, sigPatCtxt )
+import TcMonoType ( checkSigTyVars, tcHsTyVar, tcHsSigType, sigPatCtxt )
import Inst ( Inst, LIE, plusLIE, emptyLIE, plusLIEs )
-import TcEnv ( tcExtendLocalValEnv, tcExtendGlobalTyVars, tcExtendTyVarEnv )
-import TcPat ( tcPat, polyPatSig )
-import TcType ( TcType, newTyVarTy, newTyVarTy_OpenKind )
+import TcEnv ( tcExtendLocalValEnv, tcExtendGlobalTyVars, tcExtendTyVarEnv, tcGetGlobalTyVars )
+import TcPat ( tcPat, tcPatBndr_NoSigs, polyPatSig )
+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)
grhss'' = glue_on Recursive ex_binds $
glue_on Recursive inst_binds grhss'
in
- returnTc (pat_ids, (Match [] pats' Nothing grhss', lie_req''))
+ returnTc (pat_ids, (Match [] pats' Nothing grhss'', lie_req''))
-- 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
= returnTc (expected_ty, [], emptyLIE, emptyBag, emptyBag, emptyLIE)
tcMatchPats (pat:pats) expected_ty
- = unifyFunTy expected_ty `thenTc` \ (arg_ty, rest_ty) ->
- tcPat noSigs pat arg_ty `thenTc` \ (pat', lie_req, pat_tvs, pat_ids, lie_avail) ->
- tcMatchPats pats rest_ty `thenTc` \ (rhs_ty, pats', lie_reqs, pats_tvs, pats_ids, lie_avails) ->
+ = unifyFunTy expected_ty `thenTc` \ (arg_ty, rest_ty) ->
+ tcPat tcPatBndr_NoSigs pat arg_ty `thenTc` \ (pat', lie_req, pat_tvs, pat_ids, lie_avail) ->
+ tcMatchPats pats rest_ty `thenTc` \ (rhs_ty, pats', lie_reqs, pats_tvs, pats_ids, lie_avails) ->
returnTc ( rhs_ty,
pat':pats',
lie_req `plusLIE` lie_reqs,
= tcAddSrcLoc src_loc (
tcSetErrCtxt (stmtCtxt do_or_lc stmt) $
newTyVarTy boxedTypeKind `thenNF_Tc` \ pat_ty ->
- tcPat noSigs pat pat_ty `thenTc` \ (pat', pat_lie, pat_tvs, pat_ids, avail) ->
+ tcPat tcPatBndr_NoSigs pat pat_ty `thenTc` \ (pat', pat_lie, pat_tvs, pat_ids, avail) ->
tcExpr exp (m pat_ty) `thenTc` \ (exp', exp_lie) ->
returnTc (pat', exp',
pat_lie `plusLIE` exp_lie,
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
\begin{code}
matchCtxt CaseAlt match
- = hang (ptext SLIT("In a \"case\" branch:"))
+ = hang (ptext SLIT("In a case alternative:"))
4 (pprMatch (True,empty) {-is_case-} match)
matchCtxt (FunRhs fun) match
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")
projects / ghc-hetmet.git / blobdiff