-\%
+%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[TcMatches]{Typecheck some @Matches@}
import HsSyn ( HsBinds(..), Match(..), GRHSs(..), GRHS(..),
MonoBinds(..), StmtCtxt(..), Stmt(..),
- pprMatch, getMatchLoc
+ pprMatch, getMatchLoc, consLetStmt,
+ mkMonoBind, collectSigTysFromPats
)
import RnHsSyn ( RenamedMatch, RenamedGRHSs, RenamedStmt )
import TcHsSyn ( TcMatch, TcGRHSs, TcStmt )
import TcMonad
-import TcMonoType ( checkSigTyVars, tcHsTyVar, tcHsType, noSigs, sigPatCtxt )
-import Inst ( Inst, LIE, plusLIE, emptyLIE, plusLIEs )
-import TcEnv ( tcExtendLocalValEnv, tcExtendGlobalTyVars, tcExtendTyVarEnv )
-import TcPat ( tcPat, polyPatSig )
-import TcType ( TcType, newTyVarTy, newTyVarTy_OpenKind )
+import TcMonoType ( kcHsSigType, tcTyVars, checkSigTyVars, tcHsSigType, sigPatCtxt )
+import Inst ( LIE, plusLIE, emptyLIE, plusLIEs )
+import TcEnv ( TcId, tcExtendTyVarEnv, tcExtendLocalValEnv, tcExtendGlobalTyVars )
+import TcPat ( tcPat, tcPatBndr_NoSigs, polyPatSig )
+import TcType ( TcType, newTyVarTy )
import TcBinds ( tcBindsAndThen )
import TcSimplify ( tcSimplifyAndCheck, bindInstsOfLocalFuns )
-import TcUnify ( unifyFunTy, unifyTauTy )
+import TcUnify ( unifyFunTy, unifyTauTy, unifyListTy )
import Name ( Name )
import TysWiredIn ( boolTy )
import BasicTypes ( RecFlag(..) )
-import Type ( Kind, tyVarsOfType, isTauTy, mkFunTy, boxedTypeKind )
+import Type ( tyVarsOfType, isTauTy, mkArrowKind, mkAppTy, mkFunTy,
+ boxedTypeKind, openTypeKind )
+import SrcLoc ( SrcLoc )
import VarSet
import Var ( Id )
-import Util
import Bag
import Outputable
import List ( nub )
-> Name
-> TcType -- Expected type
-> [RenamedMatch]
- -> TcM s ([TcMatch], LIE)
+ -> TcM ([TcMatch], LIE)
tcMatchesFun xve fun_name expected_ty matches@(first_match:_)
= -- Check that they all have the same no of arguments
\begin{code}
tcMatchesCase :: [RenamedMatch] -- The case alternatives
-> TcType -- Type of whole case expressions
- -> TcM s (TcType, -- Inferred type of the scrutinee
+ -> TcM (TcType, -- Inferred type of the scrutinee
[TcMatch], -- Translated alternatives
LIE)
tcMatchesCase matches expr_ty
- = newTyVarTy_OpenKind `thenNF_Tc` \ scrut_ty ->
+ = newTyVarTy openTypeKind `thenNF_Tc` \ scrut_ty ->
tcMatches [] matches (mkFunTy scrut_ty expr_ty) CaseAlt `thenTc` \ (matches', lie) ->
returnTc (scrut_ty, matches', lie)
-tcMatchLambda :: RenamedMatch -> TcType -> TcM s (TcMatch, LIE)
+tcMatchLambda :: RenamedMatch -> TcType -> TcM (TcMatch, LIE)
tcMatchLambda match res_ty = tcMatch [] match res_ty LambdaBody
\end{code}
-> [RenamedMatch]
-> TcType
-> StmtCtxt
- -> TcM s ([TcMatch], LIE)
+ -> TcM ([TcMatch], LIE)
tcMatches xve matches expected_ty fun_or_case
= mapAndUnzipTc tc_match matches `thenTc` \ (matches, lies) ->
-> TcType -- Expected result-type of the Match.
-- Early unification with this guy gives better error messages
-> StmtCtxt
- -> TcM s (TcMatch, LIE)
+ -> TcM (TcMatch, LIE)
tcMatch xve1 match@(Match sig_tvs pats maybe_rhs_sig grhss) expected_ty ctxt
= tcAddSrcLoc (getMatchLoc match) $
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 ->
+ newTyVarTy openTypeKind `thenNF_Tc` \ tyvar_ty ->
-- Extend the tyvar env and check the match itself
- mapNF_Tc tcHsTyVar sig_tvs `thenNF_Tc` \ sig_tyvars ->
- tcExtendTyVarEnv sig_tyvars (
- tc_match tyvar_ty
- ) `thenTc` \ (pat_ids, match_and_lie) ->
+ tcTyVars sig_tvs (mapTc_ kcHsSigType sig_tys) `thenTc` \ sig_tyvars ->
+ tcExtendTyVarEnv sig_tyvars (tc_match tyvar_ty) `thenTc` \ (pat_ids, match_and_lie) ->
-- 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
+ sig_tys = case maybe_rhs_sig of { Just t -> [t]; Nothing -> [] }
+ ++ collectSigTysFromPats pats
+
+ 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
- -> TcM s (TcGRHSs, LIE)
+ -> TcM (TcGRHSs, LIE)
tcGRHSs (GRHSs grhss binds _) expected_ty ctxt
= tcBindsAndThen glue_on binds (tc_grhss grhss)
where
tc_grhss grhss
- = mapAndUnzipTc tc_grhs grhss `thenTc` \ (grhss', lies) ->
+ = mapAndUnzipTc tc_grhs grhss `thenTc` \ (grhss', lies) ->
returnTc (GRHSs grhss' EmptyBinds (Just expected_ty), plusLIEs lies)
tc_grhs (GRHS guarded locn)
= tcAddSrcLoc locn $
- tcStmts ctxt (\ty -> ty) guarded expected_ty `thenTc` \ (guarded', lie) ->
+ tcStmts ctxt (\ty -> ty) expected_ty locn guarded
+ `thenTc` \ ((guarded', _), lie) ->
returnTc (GRHS guarded' locn, lie)
\end{code}
= 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,
\begin{code}
+tcParStep src_loc stmts
+ = newTyVarTy (mkArrowKind boxedTypeKind boxedTypeKind) `thenTc` \ m ->
+ newTyVarTy boxedTypeKind `thenTc` \ elt_ty ->
+ unifyListTy (mkAppTy m elt_ty) `thenTc_`
+
+ tcStmts ListComp (mkAppTy m) elt_ty src_loc stmts `thenTc` \ ((stmts', val_env), stmts_lie) ->
+ returnTc (stmts', val_env, stmts_lie)
+
tcStmts :: StmtCtxt
- -> (TcType -> TcType) -- m, the relationship type of pat and rhs in pat <- rhs
- -> [RenamedStmt]
+ -> (TcType -> TcType) -- m, the relationship type of pat and rhs in pat <- rhs
-> TcType -- elt_ty, where type of the comprehension is (m elt_ty)
- -> TcM s ([TcStmt], LIE)
+ -> SrcLoc
+ -> [RenamedStmt]
+ -> TcM (([TcStmt], [(Name, TcId)]), LIE)
+
+tcStmts do_or_lc m elt_ty loc (ParStmtOut bndrstmtss : stmts)
+ = let (bndrss, stmtss) = unzip bndrstmtss in
+ mapAndUnzip3Tc (tcParStep loc) stmtss `thenTc` \ (stmtss', val_envs, lies) ->
+ let outstmts = zip (map (map snd) val_envs) stmtss'
+ lie = plusLIEs lies
+ new_val_env = concat val_envs
+ in
+ tcExtendLocalValEnv new_val_env (
+ tcStmts do_or_lc m elt_ty loc stmts) `thenTc` \ ((stmts', rest_val_env), stmts_lie) ->
+ returnTc ((ParStmtOut outstmts : stmts', rest_val_env ++ new_val_env), lie `plusLIE` stmts_lie)
-tcStmts do_or_lc m (stmt@(ReturnStmt exp) : stmts) elt_ty
+tcStmts do_or_lc m elt_ty loc (stmt@(ReturnStmt exp) : stmts)
= ASSERT( null stmts )
tcSetErrCtxt (stmtCtxt do_or_lc stmt) $
tcExpr exp elt_ty `thenTc` \ (exp', exp_lie) ->
- returnTc ([ReturnStmt exp'], exp_lie)
+ returnTc (([ReturnStmt exp'], []), exp_lie)
-- ExprStmt at the end
-tcStmts do_or_lc m [stmt@(ExprStmt exp src_loc)] elt_ty
+tcStmts do_or_lc m elt_ty loc [stmt@(ExprStmt exp src_loc)]
= tcSetErrCtxt (stmtCtxt do_or_lc stmt) $
tcExpr exp (m elt_ty) `thenTc` \ (exp', exp_lie) ->
- returnTc ([ExprStmt exp' src_loc], exp_lie)
+ returnTc (([ExprStmt exp' src_loc], []), exp_lie)
-- ExprStmt not at the end
-tcStmts do_or_lc m (stmt@(ExprStmt exp src_loc) : stmts) elt_ty
+tcStmts do_or_lc m elt_ty loc (stmt@(ExprStmt exp src_loc) : stmts)
= ASSERT( isDoStmt do_or_lc )
tcAddSrcLoc src_loc (
tcSetErrCtxt (stmtCtxt do_or_lc stmt) $
-- exp has type (m tau) for some tau (doesn't matter what)
- newTyVarTy_OpenKind `thenNF_Tc` \ any_ty ->
+ newTyVarTy openTypeKind `thenNF_Tc` \ any_ty ->
tcExpr exp (m any_ty)
) `thenTc` \ (exp', exp_lie) ->
- tcStmts do_or_lc m stmts elt_ty `thenTc` \ (stmts', stmts_lie) ->
- returnTc (ExprStmt exp' src_loc : stmts',
+ tcStmts do_or_lc m elt_ty loc stmts `thenTc` \ ((stmts', rest_val_env), stmts_lie) ->
+ returnTc ((ExprStmt exp' src_loc : stmts', rest_val_env),
exp_lie `plusLIE` stmts_lie)
-tcStmts do_or_lc m (stmt@(GuardStmt exp src_loc) : stmts) elt_ty
+tcStmts do_or_lc m elt_ty loc (stmt@(GuardStmt exp src_loc) : stmts)
= ASSERT( not (isDoStmt do_or_lc) )
tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
tcAddSrcLoc src_loc $
tcExpr exp boolTy
) `thenTc` \ (exp', exp_lie) ->
- tcStmts do_or_lc m stmts elt_ty `thenTc` \ (stmts', stmts_lie) ->
- returnTc (GuardStmt exp' src_loc : stmts',
+ tcStmts do_or_lc m elt_ty loc stmts `thenTc` \ ((stmts', rest_val_env), stmts_lie) ->
+ -- ZZ is this right?
+ returnTc ((GuardStmt exp' src_loc : stmts', rest_val_env),
exp_lie `plusLIE` stmts_lie)
-tcStmts do_or_lc m (stmt@(BindStmt pat exp src_loc) : stmts) elt_ty
+tcStmts do_or_lc m elt_ty loc (stmt@(BindStmt pat exp src_loc) : stmts)
= 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,
-- Do the rest; we don't need to add the pat_tvs to the envt
-- because they all appear in the pat_ids's types
tcExtendLocalValEnv new_val_env (
- tcStmts do_or_lc m stmts elt_ty
- ) `thenTc` \ (stmts', stmts_lie) ->
+ tcStmts do_or_lc m elt_ty loc stmts
+ ) `thenTc` \ ((stmts', rest_val_env), stmts_lie) ->
-- Reinstate context for existential checks
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"))
(mkVarSet zonked_pat_tvs)
lie_avail stmts_lie `thenTc` \ (final_lie, dict_binds) ->
- returnTc (BindStmt pat' exp' src_loc :
- LetStmt (MonoBind dict_binds [] Recursive) :
- stmts',
- lie_req `plusLIE` final_lie)
+ -- ZZ we have to be sure that concating the val_env lists preserves
+ -- shadowing properly...
+ returnTc ((BindStmt pat' exp' src_loc :
+ consLetStmt (mkMonoBind dict_binds [] Recursive) stmts',
+ rest_val_env ++ new_val_env),
+ lie_req `plusLIE` final_lie)
-tcStmts do_or_lc m (LetStmt binds : stmts) elt_ty
+tcStmts do_or_lc m elt_ty loc (LetStmt binds : stmts)
= tcBindsAndThen -- No error context, but a binding group is
combine -- rather a large thing for an error context anyway
binds
- (tcStmts do_or_lc m stmts elt_ty)
+ (tcStmts do_or_lc m elt_ty loc stmts) `thenTc` \ ((stmts', rest_val_env), lie) ->
+ -- ZZ fix val_env
+ returnTc ((stmts', rest_val_env), lie)
where
- combine is_rec binds' stmts' = LetStmt (MonoBind binds' [] is_rec) : stmts'
+ combine is_rec binds' (stmts', val_env) = (consLetStmt (mkMonoBind binds' [] is_rec) stmts', undefined)
+tcStmts do_or_lc m elt_ty loc [] = returnTc (([], []), emptyLIE)
isDoStmt DoStmt = True
isDoStmt other = False
\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")