summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
authorIan Lynagh <ian@well-typed.com>2013-05-12 15:01:13 +0100
committerIan Lynagh <ian@well-typed.com>2013-05-12 15:01:13 +0100
commita2be710f4bb005c2e339799da4b63d376adfaf6b (patch)
treef7944760d0c1ff87a2c67895d0fb4c78abe9734a /compiler
parent4e84e51ef9d4a43c2bbb037191b140729d925548 (diff)
downloadhaskell-a2be710f4bb005c2e339799da4b63d376adfaf6b.tar.gz
Modernise some code
Use do notation rather than thenM in typecheck/TcHsSyn.lhs
Diffstat (limited to 'compiler')
-rw-r--r--compiler/typecheck/TcHsSyn.lhs281
1 files changed, 137 insertions, 144 deletions
diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs
index b065f04268..04e5582df1 100644
--- a/compiler/typecheck/TcHsSyn.lhs
+++ b/compiler/typecheck/TcHsSyn.lhs
@@ -55,13 +55,6 @@ import Outputable
import Util
\end{code}
-\begin{code}
--- XXX
-thenM :: Monad a => a b -> (b -> a c) -> a c
-thenM = (>>=)
-\end{code}
-
-
%************************************************************************
%* *
\subsection[mkFailurePair]{Code for pattern-matching and other failures}
@@ -242,8 +235,8 @@ zonkIdOccs env ids = map (zonkIdOcc env) ids
-- to its final form. The TyVarEnv give
zonkIdBndr :: ZonkEnv -> TcId -> TcM Id
zonkIdBndr env id
- = zonkTcTypeToType env (idType id) `thenM` \ ty' ->
- return (Id.setIdType id ty')
+ = do ty' <- zonkTcTypeToType env (idType id)
+ return (Id.setIdType id ty')
zonkIdBndrs :: ZonkEnv -> [TcId] -> TcM [Id]
zonkIdBndrs env ids = mapM (zonkIdBndr env) ids
@@ -343,18 +336,17 @@ zonkLocalBinds env (HsValBinds vb@(ValBindsOut binds sigs))
; (env2, bs') <- go env1 sig_warn bs
; return (env2, (r,b'):bs') }
-zonkLocalBinds env (HsIPBinds (IPBinds binds dict_binds))
- = mapM (wrapLocM zonk_ip_bind) binds `thenM` \ new_binds ->
+zonkLocalBinds env (HsIPBinds (IPBinds binds dict_binds)) = do
+ new_binds <- mapM (wrapLocM zonk_ip_bind) binds
let
env1 = extendIdZonkEnv env [ n | L _ (IPBind (Right n) _) <- new_binds]
- in
- zonkTcEvBinds env1 dict_binds `thenM` \ (env2, new_dict_binds) ->
+ (env2, new_dict_binds) <- zonkTcEvBinds env1 dict_binds
return (env2, HsIPBinds (IPBinds new_binds new_dict_binds))
where
zonk_ip_bind (IPBind n e)
- = mapIPNameTc (zonkIdBndr env) n `thenM` \ n' ->
- zonkLExpr env e `thenM` \ e' ->
- return (IPBind n' e')
+ = do n' <- mapIPNameTc (zonkIdBndr env) n
+ e' <- zonkLExpr env e
+ return (IPBind n' e')
---------------------------------------------
zonkRecMonoBinds :: ZonkEnv -> SigWarn -> LHsBinds TcId -> TcM (ZonkEnv, LHsBinds Id)
@@ -455,11 +447,12 @@ zonk_bind env sig_warn (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs
where
zonkExport env (ABE{ abe_wrap = wrap, abe_poly = poly_id
, abe_mono = mono_id, abe_prags = prags })
- = zonkIdBndr env poly_id `thenM` \ new_poly_id ->
- zonkCoFn env wrap `thenM` \ (_, new_wrap) ->
- zonkSpecPrags env prags `thenM` \ new_prags ->
- return (ABE{ abe_wrap = new_wrap, abe_poly = new_poly_id
- , abe_mono = zonkIdOcc env mono_id, abe_prags = new_prags })
+ = do new_poly_id <- zonkIdBndr env poly_id
+ (_, new_wrap) <- zonkCoFn env wrap
+ new_prags <- zonkSpecPrags env prags
+ return (ABE{ abe_wrap = new_wrap, abe_poly = new_poly_id
+ , abe_mono = zonkIdOcc env mono_id
+ , abe_prags = new_prags })
zonkSpecPrags :: ZonkEnv -> TcSpecPrags -> TcM TcSpecPrags
zonkSpecPrags _ IsDefaultMethod = return IsDefaultMethod
@@ -504,15 +497,14 @@ zonkGRHSs :: ZonkEnv
-> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id)))
-> GRHSs TcId (Located (body TcId)) -> TcM (GRHSs Id (Located (body Id)))
-zonkGRHSs env zBody (GRHSs grhss binds)
- = zonkLocalBinds env binds `thenM` \ (new_env, new_binds) ->
+zonkGRHSs env zBody (GRHSs grhss binds) = do
+ (new_env, new_binds) <- zonkLocalBinds env binds
let
zonk_grhs (GRHS guarded rhs)
- = zonkStmts new_env zonkLExpr guarded `thenM` \ (env2, new_guarded) ->
- zBody env2 rhs `thenM` \ new_rhs ->
- return (GRHS new_guarded new_rhs)
- in
- mapM (wrapLocM zonk_grhs) grhss `thenM` \ new_grhss ->
+ = do (env2, new_guarded) <- zonkStmts new_env zonkLExpr guarded
+ new_rhs <- zBody env2 rhs
+ return (GRHS new_guarded new_rhs)
+ new_grhss <- mapM (wrapLocM zonk_grhs) grhss
return (GRHSs new_grhss new_binds)
\end{code}
@@ -537,8 +529,8 @@ zonkExpr _ (HsIPVar id)
= return (HsIPVar id)
zonkExpr env (HsLit (HsRat f ty))
- = zonkTcTypeToType env ty `thenM` \ new_ty ->
- return (HsLit (HsRat f new_ty))
+ = do new_ty <- zonkTcTypeToType env ty
+ return (HsLit (HsRat f new_ty))
zonkExpr _ (HsLit lit)
= return (HsLit lit)
@@ -548,53 +540,53 @@ zonkExpr env (HsOverLit lit)
; return (HsOverLit lit') }
zonkExpr env (HsLam matches)
- = zonkMatchGroup env zonkLExpr matches `thenM` \ new_matches ->
- return (HsLam new_matches)
+ = do new_matches <- zonkMatchGroup env zonkLExpr matches
+ return (HsLam new_matches)
zonkExpr env (HsLamCase arg matches)
- = zonkTcTypeToType env arg `thenM` \ new_arg ->
- zonkMatchGroup env zonkLExpr matches `thenM` \ new_matches ->
- return (HsLamCase new_arg new_matches)
+ = do new_arg <- zonkTcTypeToType env arg
+ new_matches <- zonkMatchGroup env zonkLExpr matches
+ return (HsLamCase new_arg new_matches)
zonkExpr env (HsApp e1 e2)
- = zonkLExpr env e1 `thenM` \ new_e1 ->
- zonkLExpr env e2 `thenM` \ new_e2 ->
- return (HsApp new_e1 new_e2)
+ = do new_e1 <- zonkLExpr env e1
+ new_e2 <- zonkLExpr env e2
+ return (HsApp new_e1 new_e2)
zonkExpr env (HsBracketOut body bs)
- = mapM zonk_b bs `thenM` \ bs' ->
- return (HsBracketOut body bs')
+ = do bs' <- mapM zonk_b bs
+ return (HsBracketOut body bs')
where
- zonk_b (n,e) = zonkLExpr env e `thenM` \ e' ->
- return (n,e')
+ zonk_b (n,e) = do e' <- zonkLExpr env e
+ return (n,e')
zonkExpr _ (HsSpliceE s) = WARN( True, ppr s ) -- Should not happen
return (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 ->
- return (OpApp new_e1 new_op fixity new_e2)
+ = do new_e1 <- zonkLExpr env e1
+ new_op <- zonkLExpr env op
+ new_e2 <- zonkLExpr env e2
+ return (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 ->
- return (NegApp new_expr new_op)
+ = do new_expr <- zonkLExpr env expr
+ new_op <- zonkExpr env op
+ return (NegApp new_expr new_op)
zonkExpr env (HsPar e)
- = zonkLExpr env e `thenM` \new_e ->
- return (HsPar new_e)
+ = do new_e <- zonkLExpr env e
+ return (HsPar new_e)
zonkExpr env (SectionL expr op)
- = zonkLExpr env expr `thenM` \ new_expr ->
- zonkLExpr env op `thenM` \ new_op ->
- return (SectionL new_expr new_op)
+ = do new_expr <- zonkLExpr env expr
+ new_op <- zonkLExpr env op
+ return (SectionL new_expr new_op)
zonkExpr env (SectionR op expr)
- = zonkLExpr env op `thenM` \ new_op ->
- zonkLExpr env expr `thenM` \ new_expr ->
- return (SectionR new_op new_expr)
+ = do new_op <- zonkLExpr env op
+ new_expr <- zonkLExpr env expr
+ return (SectionR new_op new_expr)
zonkExpr env (ExplicitTuple tup_args boxed)
= do { new_tup_args <- mapM zonk_tup_arg tup_args
@@ -604,9 +596,9 @@ zonkExpr env (ExplicitTuple tup_args boxed)
zonk_tup_arg (Missing t) = do { t' <- zonkTcTypeToType env t; return (Missing t') }
zonkExpr env (HsCase expr ms)
- = zonkLExpr env expr `thenM` \ new_expr ->
- zonkMatchGroup env zonkLExpr ms `thenM` \ new_ms ->
- return (HsCase new_expr new_ms)
+ = do new_expr <- zonkLExpr env expr
+ new_ms <- zonkMatchGroup env zonkLExpr ms
+ return (HsCase new_expr new_ms)
zonkExpr env (HsIf e0 e1 e2 e3)
= do { new_e0 <- fmapMaybeM (zonkExpr env) e0
@@ -625,28 +617,28 @@ zonkExpr env (HsMultiIf ty alts)
; return $ GRHS guard' expr' }
zonkExpr env (HsLet binds expr)
- = zonkLocalBinds env binds `thenM` \ (new_env, new_binds) ->
- zonkLExpr new_env expr `thenM` \ new_expr ->
- return (HsLet new_binds new_expr)
+ = do (new_env, new_binds) <- zonkLocalBinds env binds
+ new_expr <- zonkLExpr new_env expr
+ return (HsLet new_binds new_expr)
zonkExpr env (HsDo do_or_lc stmts ty)
- = zonkStmts env zonkLExpr stmts `thenM` \ (_, new_stmts) ->
- zonkTcTypeToType env ty `thenM` \ new_ty ->
- return (HsDo do_or_lc new_stmts new_ty)
+ = do (_, new_stmts) <- zonkStmts env zonkLExpr stmts
+ new_ty <- zonkTcTypeToType env ty
+ return (HsDo do_or_lc new_stmts new_ty)
zonkExpr env (ExplicitList ty wit exprs)
- = zonkTcTypeToType env ty `thenM` \ new_ty ->
- zonkWit env wit `thenM` \ new_wit ->
- zonkLExprs env exprs `thenM` \ new_exprs ->
- return (ExplicitList new_ty new_wit new_exprs)
+ = do new_ty <- zonkTcTypeToType env ty
+ new_wit <- zonkWit env wit
+ new_exprs <- zonkLExprs env exprs
+ return (ExplicitList new_ty new_wit new_exprs)
where zonkWit _ Nothing = return Nothing
- zonkWit env (Just fln) = zonkExpr env fln `thenM` \ new_fln ->
- return (Just new_fln)
+ zonkWit env (Just fln) = do new_fln <- zonkExpr env fln
+ return (Just new_fln)
zonkExpr env (ExplicitPArr ty exprs)
- = zonkTcTypeToType env ty `thenM` \ new_ty ->
- zonkLExprs env exprs `thenM` \ new_exprs ->
- return (ExplicitPArr new_ty new_exprs)
+ = do new_ty <- zonkTcTypeToType env ty
+ new_exprs <- zonkLExprs env exprs
+ return (ExplicitPArr new_ty new_exprs)
zonkExpr env (RecordCon data_con con_expr rbinds)
= do { new_con_expr <- zonkExpr env con_expr
@@ -667,31 +659,31 @@ zonkExpr env (ExprWithTySigOut e ty)
zonkExpr _ (ExprWithTySig _ _) = panic "zonkExpr env:ExprWithTySig"
zonkExpr env (ArithSeq expr wit info)
- = zonkExpr env expr `thenM` \ new_expr ->
- zonkWit env wit `thenM` \ new_wit ->
- zonkArithSeq env info `thenM` \ new_info ->
- return (ArithSeq new_expr new_wit new_info)
+ = do new_expr <- zonkExpr env expr
+ new_wit <- zonkWit env wit
+ new_info <- zonkArithSeq env info
+ return (ArithSeq new_expr new_wit new_info)
where zonkWit _ Nothing = return Nothing
- zonkWit env (Just fln) = zonkExpr env fln `thenM` \ new_fln ->
- return (Just new_fln)
+ zonkWit env (Just fln) = do new_fln <- zonkExpr env fln
+ return (Just new_fln)
zonkExpr env (PArrSeq expr info)
- = zonkExpr env expr `thenM` \ new_expr ->
- zonkArithSeq env info `thenM` \ new_info ->
- return (PArrSeq new_expr new_info)
+ = do new_expr <- zonkExpr env expr
+ new_info <- zonkArithSeq env info
+ return (PArrSeq new_expr new_info)
zonkExpr env (HsSCC lbl expr)
- = zonkLExpr env expr `thenM` \ new_expr ->
- return (HsSCC lbl new_expr)
+ = do new_expr <- zonkLExpr env expr
+ return (HsSCC lbl new_expr)
zonkExpr env (HsTickPragma info expr)
- = zonkLExpr env expr `thenM` \ new_expr ->
- return (HsTickPragma info new_expr)
+ = do new_expr <- zonkLExpr env expr
+ return (HsTickPragma info new_expr)
-- hdaume: core annotations
zonkExpr env (HsCoreAnn lbl expr)
- = zonkLExpr env expr `thenM` \ new_expr ->
- return (HsCoreAnn lbl new_expr)
+ = do new_expr <- zonkLExpr env expr
+ return (HsCoreAnn lbl new_expr)
-- arrow notation extensions
zonkExpr env (HsProc pat body)
@@ -700,9 +692,9 @@ zonkExpr env (HsProc pat body)
; return (HsProc new_pat new_body) }
zonkExpr env (HsWrap co_fn expr)
- = zonkCoFn env co_fn `thenM` \ (env1, new_co_fn) ->
- zonkExpr env1 expr `thenM` \ new_expr ->
- return (HsWrap new_co_fn new_expr)
+ = do (env1, new_co_fn) <- zonkCoFn env co_fn
+ new_expr <- zonkExpr env1 expr
+ return (HsWrap new_co_fn new_expr)
zonkExpr _ (HsUnboundVar v)
= return (HsUnboundVar v)
@@ -721,33 +713,33 @@ zonkCmd env (HsCmdCast co cmd)
; cmd' <- zonkCmd env cmd
; return (HsCmdCast co' cmd') }
zonkCmd env (HsCmdArrApp e1 e2 ty ho rl)
- = zonkLExpr env e1 `thenM` \ new_e1 ->
- zonkLExpr env e2 `thenM` \ new_e2 ->
- zonkTcTypeToType env ty `thenM` \ new_ty ->
- return (HsCmdArrApp new_e1 new_e2 new_ty ho rl)
+ = do new_e1 <- zonkLExpr env e1
+ new_e2 <- zonkLExpr env e2
+ new_ty <- zonkTcTypeToType env ty
+ return (HsCmdArrApp new_e1 new_e2 new_ty ho rl)
zonkCmd env (HsCmdArrForm op fixity args)
- = zonkLExpr env op `thenM` \ new_op ->
- mapM (zonkCmdTop env) args `thenM` \ new_args ->
- return (HsCmdArrForm new_op fixity new_args)
+ = do new_op <- zonkLExpr env op
+ new_args <- mapM (zonkCmdTop env) args
+ return (HsCmdArrForm new_op fixity new_args)
zonkCmd env (HsCmdApp c e)
- = zonkLCmd env c `thenM` \ new_c ->
- zonkLExpr env e `thenM` \ new_e ->
- return (HsCmdApp new_c new_e)
+ = do new_c <- zonkLCmd env c
+ new_e <- zonkLExpr env e
+ return (HsCmdApp new_c new_e)
zonkCmd env (HsCmdLam matches)
- = zonkMatchGroup env zonkLCmd matches `thenM` \ new_matches ->
- return (HsCmdLam new_matches)
+ = do new_matches <- zonkMatchGroup env zonkLCmd matches
+ return (HsCmdLam new_matches)
zonkCmd env (HsCmdPar c)
- = zonkLCmd env c `thenM` \new_c ->
- return (HsCmdPar new_c)
+ = do new_c <- zonkLCmd env c
+ return (HsCmdPar new_c)
zonkCmd env (HsCmdCase expr ms)
- = zonkLExpr env expr `thenM` \ new_expr ->
- zonkMatchGroup env zonkLCmd ms `thenM` \ new_ms ->
- return (HsCmdCase new_expr new_ms)
+ = do new_expr <- zonkLExpr env expr
+ new_ms <- zonkMatchGroup env zonkLCmd ms
+ return (HsCmdCase new_expr new_ms)
zonkCmd env (HsCmdIf eCond ePred cThen cElse)
= do { new_eCond <- fmapMaybeM (zonkExpr env) eCond
@@ -757,14 +749,14 @@ zonkCmd env (HsCmdIf eCond ePred cThen cElse)
; return (HsCmdIf new_eCond new_ePred new_cThen new_cElse) }
zonkCmd env (HsCmdLet binds cmd)
- = zonkLocalBinds env binds `thenM` \ (new_env, new_binds) ->
- zonkLCmd new_env cmd `thenM` \ new_cmd ->
- return (HsCmdLet new_binds new_cmd)
+ = do (new_env, new_binds) <- zonkLocalBinds env binds
+ new_cmd <- zonkLCmd new_env cmd
+ return (HsCmdLet new_binds new_cmd)
zonkCmd env (HsCmdDo stmts ty)
- = zonkStmts env zonkLCmd stmts `thenM` \ (_, new_stmts) ->
- zonkTcTypeToType env ty `thenM` \ new_ty ->
- return (HsCmdDo new_stmts new_ty)
+ = do (_, new_stmts) <- zonkStmts env zonkLCmd stmts
+ new_ty <- zonkTcTypeToType env ty
+ return (HsCmdDo new_stmts new_ty)
@@ -775,11 +767,11 @@ zonkCmdTop env cmd = wrapLocM (zonk_cmd_top env) cmd
zonk_cmd_top :: ZonkEnv -> HsCmdTop TcId -> TcM (HsCmdTop Id)
zonk_cmd_top env (HsCmdTop cmd stack_tys ty ids)
- = zonkLCmd env cmd `thenM` \ new_cmd ->
- zonkTcTypeToType env stack_tys `thenM` \ new_stack_tys ->
- zonkTcTypeToType env ty `thenM` \ new_ty ->
- mapSndM (zonkExpr env) ids `thenM` \ new_ids ->
- return (HsCmdTop new_cmd new_stack_tys new_ty new_ids)
+ = do new_cmd <- zonkLCmd env cmd
+ new_stack_tys <- zonkTcTypeToType env stack_tys
+ new_ty <- zonkTcTypeToType env ty
+ new_ids <- mapSndM (zonkExpr env) ids
+ return (HsCmdTop new_cmd new_stack_tys new_ty new_ids)
-------------------------------------------------------------------------
zonkCoFn :: ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper)
@@ -812,24 +804,24 @@ zonkOverLit env lit@(OverLit { ol_witness = e, ol_type = ty })
zonkArithSeq :: ZonkEnv -> ArithSeqInfo TcId -> TcM (ArithSeqInfo Id)
zonkArithSeq env (From e)
- = zonkLExpr env e `thenM` \ new_e ->
- return (From new_e)
+ = do new_e <- zonkLExpr env e
+ return (From new_e)
zonkArithSeq env (FromThen e1 e2)
- = zonkLExpr env e1 `thenM` \ new_e1 ->
- zonkLExpr env e2 `thenM` \ new_e2 ->
- return (FromThen new_e1 new_e2)
+ = do new_e1 <- zonkLExpr env e1
+ new_e2 <- zonkLExpr env e2
+ return (FromThen new_e1 new_e2)
zonkArithSeq env (FromTo e1 e2)
- = zonkLExpr env e1 `thenM` \ new_e1 ->
- zonkLExpr env e2 `thenM` \ new_e2 ->
- return (FromTo new_e1 new_e2)
+ = do new_e1 <- zonkLExpr env e1
+ new_e2 <- zonkLExpr env e2
+ return (FromTo new_e1 new_e2)
zonkArithSeq env (FromThenTo e1 e2 e3)
- = zonkLExpr env e1 `thenM` \ new_e1 ->
- zonkLExpr env e2 `thenM` \ new_e2 ->
- zonkLExpr env e3 `thenM` \ new_e3 ->
- return (FromThenTo new_e1 new_e2 new_e3)
+ = do new_e1 <- zonkLExpr env e1
+ new_e2 <- zonkLExpr env e2
+ new_e3 <- zonkLExpr env e3
+ return (FromThenTo new_e1 new_e2 new_e3)
-------------------------------------------------------------------------
@@ -881,16 +873,16 @@ zonkStmt env zBody (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_
, recS_rec_rets = new_rec_rets, recS_ret_ty = new_ret_ty }) }
zonkStmt env zBody (BodyStmt body then_op guard_op ty)
- = zBody env body `thenM` \ new_body ->
- zonkExpr env then_op `thenM` \ new_then ->
- zonkExpr env guard_op `thenM` \ new_guard ->
- zonkTcTypeToType env ty `thenM` \ new_ty ->
- return (env, BodyStmt new_body new_then new_guard new_ty)
+ = do new_body <- zBody env body
+ new_then <- zonkExpr env then_op
+ new_guard <- zonkExpr env guard_op
+ new_ty <- zonkTcTypeToType env ty
+ return (env, BodyStmt new_body new_then new_guard new_ty)
zonkStmt env zBody (LastStmt body ret_op)
- = zBody env body `thenM` \ new_body ->
- zonkExpr env ret_op `thenM` \ new_ret ->
- return (env, LastStmt new_body new_ret)
+ = do new_body <- zBody env body
+ new_ret <- zonkExpr env ret_op
+ return (env, LastStmt new_body new_ret)
zonkStmt env _ (TransStmt { trS_stmts = stmts, trS_bndrs = binderMap
, trS_by = by, trS_form = form, trS_using = using
@@ -913,8 +905,8 @@ zonkStmt env _ (TransStmt { trS_stmts = stmts, trS_bndrs = binderMap
return (oldBinder', newBinder')
zonkStmt env _ (LetStmt binds)
- = zonkLocalBinds env binds `thenM` \ (env1, new_binds) ->
- return (env1, LetStmt new_binds)
+ = do (env1, new_binds) <- zonkLocalBinds env binds
+ return (env1, LetStmt new_binds)
zonkStmt env zBody (BindStmt pat body bind_op fail_op)
= do { new_body <- zBody env body
@@ -937,7 +929,8 @@ zonkRecFields env (HsRecFields flds dd)
-------------------------------------------------------------------------
mapIPNameTc :: (a -> TcM b) -> Either HsIPName a -> TcM (Either HsIPName b)
mapIPNameTc _ (Left x) = return (Left x)
-mapIPNameTc f (Right x) = f x `thenM` \ r -> return (Right r)
+mapIPNameTc f (Right x) = do r <- f x
+ return (Right r)
\end{code}