+zonkExpr env (HsIPVar id)
+ = returnM (HsIPVar (mapIPName (zonkIdOcc env) id))
+
+zonkExpr env (HsLit (HsRat f ty))
+ = zonkTcTypeToType env ty `thenM` \ new_ty ->
+ returnM (HsLit (HsRat f new_ty))
+
+zonkExpr env (HsLit lit)
+ = returnM (HsLit lit)
+
+zonkExpr env (HsOverLit lit)
+ = do { lit' <- zonkOverLit env lit
+ ; return (HsOverLit lit') }
+
+zonkExpr env (HsLam matches)
+ = zonkMatchGroup env matches `thenM` \ new_matches ->
+ returnM (HsLam new_matches)
+
+zonkExpr env (HsApp e1 e2)
+ = zonkLExpr env e1 `thenM` \ new_e1 ->
+ zonkLExpr env e2 `thenM` \ new_e2 ->
+ returnM (HsApp new_e1 new_e2)
+
+zonkExpr env (HsBracketOut body bs)
+ = mappM zonk_b bs `thenM` \ bs' ->
+ returnM (HsBracketOut body bs')
+ where
+ zonk_b (n,e) = zonkLExpr env e `thenM` \ e' ->
+ returnM (n,e')
+
+zonkExpr env (HsSpliceE s) = WARN( True, ppr s ) -- Should not happen
+ returnM (HsSpliceE s)
+
+zonkExpr env (OpApp e1 op fixity e2)
+ = zonkLExpr env e1 `thenM` \ new_e1 ->
+ zonkLExpr env op `thenM` \ new_op ->
+ zonkLExpr env e2 `thenM` \ new_e2 ->
+ returnM (OpApp new_e1 new_op fixity new_e2)
+
+zonkExpr env (NegApp expr op)
+ = zonkLExpr env expr `thenM` \ new_expr ->
+ zonkExpr env op `thenM` \ new_op ->
+ returnM (NegApp new_expr new_op)
+
+zonkExpr env (HsPar e)
+ = zonkLExpr env e `thenM` \new_e ->
+ returnM (HsPar new_e)
+
+zonkExpr env (SectionL expr op)
+ = zonkLExpr env expr `thenM` \ new_expr ->
+ zonkLExpr env op `thenM` \ new_op ->
+ returnM (SectionL new_expr new_op)
+
+zonkExpr env (SectionR op expr)
+ = zonkLExpr env op `thenM` \ new_op ->
+ zonkLExpr env expr `thenM` \ new_expr ->
+ returnM (SectionR new_op new_expr)
+
+zonkExpr env (HsCase expr ms)
+ = zonkLExpr env expr `thenM` \ new_expr ->
+ zonkMatchGroup env ms `thenM` \ new_ms ->
+ returnM (HsCase new_expr new_ms)
+
+zonkExpr env (HsIf e1 e2 e3)
+ = zonkLExpr env e1 `thenM` \ new_e1 ->
+ zonkLExpr env e2 `thenM` \ new_e2 ->
+ zonkLExpr env e3 `thenM` \ new_e3 ->
+ returnM (HsIf new_e1 new_e2 new_e3)
+
+zonkExpr env (HsLet binds expr)
+ = zonkLocalBinds env binds `thenM` \ (new_env, new_binds) ->
+ zonkLExpr new_env expr `thenM` \ new_expr ->
+ returnM (HsLet new_binds new_expr)
+
+zonkExpr env (HsDo do_or_lc stmts body ty)
+ = zonkStmts env stmts `thenM` \ (new_env, new_stmts) ->
+ zonkLExpr new_env body `thenM` \ new_body ->
+ zonkTcTypeToType env ty `thenM` \ new_ty ->
+ returnM (HsDo (zonkDo env do_or_lc)
+ new_stmts new_body new_ty)
+
+zonkExpr env (ExplicitList ty exprs)
+ = zonkTcTypeToType env ty `thenM` \ new_ty ->
+ zonkLExprs env exprs `thenM` \ new_exprs ->
+ returnM (ExplicitList new_ty new_exprs)
+
+zonkExpr env (ExplicitPArr ty exprs)
+ = zonkTcTypeToType env ty `thenM` \ new_ty ->
+ zonkLExprs env exprs `thenM` \ new_exprs ->
+ returnM (ExplicitPArr new_ty new_exprs)
+
+zonkExpr env (ExplicitTuple exprs boxed)
+ = zonkLExprs env exprs `thenM` \ new_exprs ->
+ returnM (ExplicitTuple new_exprs boxed)
+
+zonkExpr env (RecordCon data_con con_expr rbinds)
+ = zonkExpr env con_expr `thenM` \ new_con_expr ->
+ zonkRbinds env rbinds `thenM` \ new_rbinds ->
+ returnM (RecordCon data_con new_con_expr new_rbinds)
+
+zonkExpr env (RecordUpd expr rbinds in_ty out_ty)
+ = zonkLExpr env expr `thenM` \ new_expr ->
+ zonkTcTypeToType env in_ty `thenM` \ new_in_ty ->
+ zonkTcTypeToType env out_ty `thenM` \ new_out_ty ->
+ zonkRbinds env rbinds `thenM` \ new_rbinds ->
+ returnM (RecordUpd new_expr new_rbinds new_in_ty new_out_ty)
+
+zonkExpr env (ExprWithTySigOut e ty)
+ = do { e' <- zonkLExpr env e
+ ; return (ExprWithTySigOut e' ty) }
+
+zonkExpr env (ExprWithTySig _ _) = panic "zonkExpr env:ExprWithTySig"
+
+zonkExpr env (ArithSeq expr info)
+ = zonkExpr env expr `thenM` \ new_expr ->
+ zonkArithSeq env info `thenM` \ new_info ->
+ returnM (ArithSeq new_expr new_info)
+
+zonkExpr env (PArrSeq expr info)
+ = zonkExpr env expr `thenM` \ new_expr ->
+ zonkArithSeq env info `thenM` \ new_info ->
+ returnM (PArrSeq new_expr new_info)
+
+zonkExpr env (HsSCC lbl expr)
+ = zonkLExpr env expr `thenM` \ new_expr ->
+ returnM (HsSCC lbl new_expr)
+
+-- hdaume: core annotations
+zonkExpr env (HsCoreAnn lbl expr)
+ = zonkLExpr env expr `thenM` \ new_expr ->
+ returnM (HsCoreAnn lbl new_expr)
+
+zonkExpr env (TyLam tyvars expr)
+ = ASSERT( all isImmutableTyVar tyvars )
+ zonkLExpr env expr `thenM` \ new_expr ->
+ returnM (TyLam tyvars new_expr)
+
+zonkExpr env (TyApp expr tys)
+ = zonkLExpr env expr `thenM` \ new_expr ->
+ zonkTcTypeToTypes env tys `thenM` \ new_tys ->
+ returnM (TyApp new_expr new_tys)
+
+zonkExpr env (DictLam dicts expr)
+ = zonkIdBndrs env dicts `thenM` \ new_dicts ->
+ let
+ env1 = extendZonkEnv env new_dicts
+ in
+ zonkLExpr env1 expr `thenM` \ new_expr ->
+ returnM (DictLam new_dicts new_expr)
+
+zonkExpr env (DictApp expr dicts)
+ = zonkLExpr env expr `thenM` \ new_expr ->
+ returnM (DictApp new_expr (zonkIdOccs env dicts))
+
+-- arrow notation extensions
+zonkExpr env (HsProc pat body)
+ = do { (env1, new_pat) <- zonkPat env pat
+ ; new_body <- zonkCmdTop env1 body
+ ; return (HsProc new_pat new_body) }
+
+zonkExpr env (HsArrApp e1 e2 ty ho rl)
+ = zonkLExpr env e1 `thenM` \ new_e1 ->
+ zonkLExpr env e2 `thenM` \ new_e2 ->
+ zonkTcTypeToType env ty `thenM` \ new_ty ->
+ returnM (HsArrApp new_e1 new_e2 new_ty ho rl)
+
+zonkExpr env (HsArrForm op fixity args)
+ = zonkLExpr env op `thenM` \ new_op ->
+ mappM (zonkCmdTop env) args `thenM` \ new_args ->
+ returnM (HsArrForm new_op fixity new_args)
+
+zonkExpr env (HsCoerce co_fn expr)
+ = zonkCoFn env co_fn `thenM` \ (env1, new_co_fn) ->
+ zonkExpr env1 expr `thenM` \ new_expr ->
+ return (HsCoerce new_co_fn new_expr)
+
+zonkExpr env other = pprPanic "zonkExpr" (ppr other)
+
+zonkCmdTop :: ZonkEnv -> LHsCmdTop TcId -> TcM (LHsCmdTop Id)
+zonkCmdTop env cmd = wrapLocM (zonk_cmd_top env) cmd
+
+zonk_cmd_top env (HsCmdTop cmd stack_tys ty ids)
+ = zonkLExpr env cmd `thenM` \ new_cmd ->
+ zonkTcTypeToTypes env stack_tys `thenM` \ new_stack_tys ->
+ zonkTcTypeToType env ty `thenM` \ new_ty ->
+ mapSndM (zonkExpr env) ids `thenM` \ new_ids ->
+ returnM (HsCmdTop new_cmd new_stack_tys new_ty new_ids)
projects / ghc-hetmet.git / blobdiff