-\%
+%
% (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, consLetStmt,
- mkMonoBind
+ mkMonoBind, collectSigTysFromPats
)
import RnHsSyn ( RenamedMatch, RenamedGRHSs, RenamedStmt )
import TcHsSyn ( TcMatch, TcGRHSs, TcStmt )
import TcMonad
-import TcMonoType ( checkSigTyVars, tcHsTyVar, tcHsSigType, sigPatCtxt )
-import Inst ( Inst, LIE, plusLIE, emptyLIE, plusLIEs )
-import TcEnv ( tcExtendLocalValEnv, tcExtendGlobalTyVars, tcExtendTyVarEnv, tcGetGlobalTyVars )
+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, newTyVarTy_OpenKind, zonkTcTyVars )
+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) $
-- 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
returnTc match_and_lie
where
+ 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) ->
-- STEP 3: Unify with the rhs type signature if any
(case maybe_rhs_sig of
Nothing -> returnTc ()
- Just sig -> tcHsSigType 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)
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}
\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 ->
-- 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
(mkVarSet zonked_pat_tvs)
lie_avail stmts_lie `thenTc` \ (final_lie, dict_binds) ->
- returnTc (BindStmt pat' exp' src_loc :
- consLetStmt (mkMonoBind 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' = consLetStmt (mkMonoBind 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
projects / ghc-hetmet.git / blobdiff