X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcHsSyn.lhs;h=cd2cadf0854870dba8bea5e03b4c22c0ddecd41b;hp=357db734cd525fe89074e84ff031ea44178b87e8;hb=c8c2f6bb7d79a2a6aeaa3233363fdf0bbbfad205;hpb=478e69b303eb2e653a2ebf5c888b5efdfef1fb9d diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index 357db73..cd2cadf 100644 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@ -35,6 +35,7 @@ import TcRnMonad import PrelNames import TcType import TcMType +import Coercion import TysPrim import TysWiredIn import DataCon @@ -43,14 +44,15 @@ import NameSet import Var import VarSet import VarEnv +import DynFlags( DynFlag(..) ) import Literal import BasicTypes import Maybes import SrcLoc -import DynFlags( DynFlag(..) ) import Bag import FastString import Outputable +-- import Data.Traversable( traverse ) \end{code} \begin{code} @@ -578,12 +580,10 @@ zonkExpr env (HsLet binds expr) zonkLExpr new_env expr `thenM` \ new_expr -> returnM (HsLet new_binds new_expr) -zonkExpr env (HsDo do_or_lc stmts body return_op ty) - = zonkStmts env stmts `thenM` \ (new_env, new_stmts) -> - zonkLExpr new_env body `thenM` \ new_body -> - zonkExpr new_env return_op `thenM` \ new_return -> +zonkExpr env (HsDo do_or_lc stmts ty) + = zonkStmts env stmts `thenM` \ (_, new_stmts) -> zonkTcTypeToType env ty `thenM` \ new_ty -> - returnM (HsDo do_or_lc new_stmts new_body new_return new_ty) + returnM (HsDo do_or_lc new_stmts new_ty) zonkExpr env (ExplicitList ty exprs) = zonkTcTypeToType env ty `thenM` \ new_ty -> @@ -677,7 +677,7 @@ zonkCoFn env WpHole = return (env, WpHole) zonkCoFn env (WpCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1 ; (env2, c2') <- zonkCoFn env1 c2 ; return (env2, WpCompose c1' c2') } -zonkCoFn env (WpCast co) = do { co' <- zonkTcTypeToType env co +zonkCoFn env (WpCast co) = do { co' <- zonkTcCoToCo env co ; return (env, WpCast co') } zonkCoFn env (WpEvLam ev) = do { (env', ev') <- zonkEvBndrX env ev ; return (env', WpEvLam ev') } @@ -745,9 +745,10 @@ zonkStmt env (ParStmt stmts_w_bndrs mzip_op bind_op return_op) zonkStmt env (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_ids = rvs , recS_ret_fn = ret_id, recS_mfix_fn = mfix_id, recS_bind_fn = bind_id - , recS_rec_rets = rets }) + , recS_rec_rets = rets, recS_ret_ty = ret_ty }) = do { new_rvs <- zonkIdBndrs env rvs ; new_lvs <- zonkIdBndrs env lvs + ; new_ret_ty <- zonkTcTypeToType env ret_ty ; new_ret_id <- zonkExpr env ret_id ; new_mfix_id <- zonkExpr env mfix_id ; new_bind_id <- zonkExpr env bind_id @@ -760,7 +761,7 @@ zonkStmt env (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_id RecStmt { recS_stmts = new_segStmts, recS_later_ids = new_lvs , recS_rec_ids = new_rvs, recS_ret_fn = new_ret_id , recS_mfix_fn = new_mfix_id, recS_bind_fn = new_bind_id - , recS_rec_rets = new_rets }) } + , recS_rec_rets = new_rets, recS_ret_ty = new_ret_ty }) } zonkStmt env (ExprStmt expr then_op guard_op ty) = zonkLExpr env expr `thenM` \ new_expr -> @@ -769,25 +770,25 @@ zonkStmt env (ExprStmt expr then_op guard_op ty) zonkTcTypeToType env ty `thenM` \ new_ty -> returnM (env, ExprStmt new_expr new_then new_guard new_ty) -zonkStmt env (TransformStmt stmts binders usingExpr maybeByExpr return_op bind_op) - = do { (env', stmts') <- zonkStmts env stmts - ; let binders' = zonkIdOccs env' binders - ; usingExpr' <- zonkLExpr env' usingExpr - ; maybeByExpr' <- zonkMaybeLExpr env' maybeByExpr - ; return_op' <- zonkExpr env' return_op - ; bind_op' <- zonkExpr env' bind_op - ; return (env', TransformStmt stmts' binders' usingExpr' maybeByExpr' return_op' bind_op') } - -zonkStmt env (GroupStmt stmts binderMap by using return_op bind_op liftM_op) +zonkStmt env (LastStmt expr ret_op) + = zonkLExpr env expr `thenM` \ new_expr -> + zonkExpr env ret_op `thenM` \ new_ret -> + returnM (env, LastStmt new_expr new_ret) + +zonkStmt env (TransStmt { trS_stmts = stmts, trS_bndrs = binderMap + , trS_by = by, trS_form = form, trS_using = using + , trS_ret = return_op, trS_bind = bind_op, trS_fmap = liftM_op }) = do { (env', stmts') <- zonkStmts env stmts ; binderMap' <- mappM (zonkBinderMapEntry env') binderMap - ; by' <- fmapMaybeM (zonkLExpr env') by - ; using' <- fmapEitherM (zonkLExpr env) (zonkExpr env) using + ; by' <- fmapMaybeM (zonkLExpr env') by + ; using' <- zonkLExpr env using ; return_op' <- zonkExpr env' return_op - ; bind_op' <- zonkExpr env' bind_op - ; liftM_op' <- zonkExpr env' liftM_op + ; bind_op' <- zonkExpr env' bind_op + ; liftM_op' <- zonkExpr env' liftM_op ; let env'' = extendZonkEnv env' (map snd binderMap') - ; return (env'', GroupStmt stmts' binderMap' by' using' return_op' bind_op' liftM_op') } + ; return (env'', TransStmt { trS_stmts = stmts', trS_bndrs = binderMap' + , trS_by = by', trS_form = form, trS_using = using' + , trS_ret = return_op', trS_bind = bind_op', trS_fmap = liftM_op' }) } where zonkBinderMapEntry env (oldBinder, newBinder) = do let oldBinder' = zonkIdOcc env oldBinder @@ -805,11 +806,6 @@ zonkStmt env (BindStmt pat expr bind_op fail_op) ; new_fail <- zonkExpr env fail_op ; return (env1, BindStmt new_pat new_expr new_bind new_fail) } -zonkMaybeLExpr :: ZonkEnv -> Maybe (LHsExpr TcId) -> TcM (Maybe (LHsExpr Id)) -zonkMaybeLExpr _ Nothing = return Nothing -zonkMaybeLExpr env (Just e) = (zonkLExpr env e) >>= (return . Just) - - ------------------------------------------------------------------------- zonkRecFields :: ZonkEnv -> HsRecordBinds TcId -> TcM (HsRecordBinds TcId) zonkRecFields env (HsRecFields flds dd) @@ -1014,7 +1010,6 @@ zonkRule env (HsRule name act (vars{-::[RuleBndr TcId]-}) lhs fv_lhs rhs fv_rhs) zonk_it env v | isId v = do { v' <- zonkIdBndr env v; return (extendZonkEnv1 env v', v') } - | isCoVar v = do { v' <- zonkEvBndr env v; return (extendZonkEnv1 env v', v') } | otherwise = ASSERT( isImmutableTyVar v) return (env, v) \end{code} @@ -1044,10 +1039,10 @@ zonkVect env (HsVect v (Just e)) zonkEvTerm :: ZonkEnv -> EvTerm -> TcM EvTerm zonkEvTerm env (EvId v) = ASSERT2( isId v, ppr v ) return (EvId (zonkIdOcc env v)) -zonkEvTerm env (EvCoercion co) = do { co' <- zonkTcTypeToType env co +zonkEvTerm env (EvCoercion co) = do { co' <- zonkTcCoToCo env co ; return (EvCoercion co') } zonkEvTerm env (EvCast v co) = ASSERT( isId v) - do { co' <- zonkTcTypeToType env co + do { co' <- zonkTcCoToCo env co ; return (EvCast (zonkIdOcc env v) co') } zonkEvTerm env (EvSuperClass d n) = return (EvSuperClass (zonkIdOcc env d) n) zonkEvTerm env (EvDFunApp df tys tms) @@ -1122,4 +1117,27 @@ zonkTypeZapping ty zonk_unbound_tyvar tv = do { let ty = anyTypeOfKind (tyVarKind tv) ; writeMetaTyVar tv ty ; return ty } + +zonkTcCoToCo :: ZonkEnv -> Coercion -> TcM Coercion +zonkTcCoToCo env co + = go co + where + go (CoVarCo cv) = return (CoVarCo (zonkEvVarOcc env cv)) + go (Refl ty) = do { ty' <- zonkTcTypeToType env ty + ; return (Refl ty') } + go (TyConAppCo tc cos) = do { cos' <- mapM go cos; return (mkTyConAppCo tc cos') } + go (AxiomInstCo ax cos) = do { cos' <- mapM go cos; return (AxiomInstCo ax cos') } + go (AppCo co1 co2) = do { co1' <- go co1; co2' <- go co2 + ; return (mkAppCo co1' co2') } + go (UnsafeCo t1 t2) = do { t1' <- zonkTcTypeToType env t1 + ; t2' <- zonkTcTypeToType env t2 + ; return (mkUnsafeCo t1' t2') } + go (SymCo co) = do { co' <- go co; return (mkSymCo co') } + go (NthCo n co) = do { co' <- go co; return (mkNthCo n co') } + go (TransCo co1 co2) = do { co1' <- go co1; co2' <- go co2 + ; return (mkTransCo co1' co2') } + go (InstCo co ty) = do { co' <- go co; ty' <- zonkTcTypeToType env ty + ; return (mkInstCo co' ty') } + go (ForAllCo tv co) = ASSERT( isImmutableTyVar tv ) + do { co' <- go co; return (mkForAllCo tv co') } \end{code}