From: Twan van Laarhoven <twanvl@gmail.com>
Date: Thu, 17 Jan 2008 16:47:46 +0000 (+0000)
Subject: Monadify deSugar/DsBinds: use do, return, applicative, standard monad functions
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=362b461d2149160d36840342add162bf84d6212d

Monadify deSugar/DsBinds: use do, return, applicative, standard monad functions
---

diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs
index ca357c5..691ac84 100644
--- a/compiler/deSugar/DsBinds.lhs
+++ b/compiler/deSugar/DsBinds.lhs
@@ -90,25 +90,25 @@ dsHsBind :: AutoScc
 	 -> HsBind Id
 	 -> DsM [(Id,CoreExpr)] -- Result
 
-dsHsBind auto_scc rest (VarBind var expr)
-  = dsLExpr expr		`thenDs` \ core_expr ->
+dsHsBind auto_scc rest (VarBind var expr) = do
+    core_expr <- dsLExpr expr
 
-	-- Dictionary bindings are always VarMonoBinds, so
-	-- we only need do this here
-    addDictScc var core_expr	`thenDs` \ core_expr' ->
-    returnDs ((var, core_expr') : rest)
+        -- Dictionary bindings are always VarMonoBinds, so
+        -- we only need do this here
+    core_expr' <- addDictScc var core_expr
+    return ((var, core_expr') : rest)
 
 dsHsBind auto_scc rest (FunBind { fun_id = L _ fun, fun_matches = matches, 
-				  fun_co_fn = co_fn, fun_tick = tick, fun_infix = inf })
-  = matchWrapper (FunRhs (idName fun) inf) matches	`thenDs` \ (args, body) ->
-    mkOptTickBox tick body 				`thenDs` \ body' ->
-    dsCoercion co_fn (return (mkLams args body'))	`thenDs` \ rhs ->
-    returnDs ((fun,rhs) : rest)
+				  fun_co_fn = co_fn, fun_tick = tick, fun_infix = inf }) = do
+    (args, body) <- matchWrapper (FunRhs (idName fun) inf) matches
+    body' <- mkOptTickBox tick body
+    rhs <- dsCoercion co_fn (return (mkLams args body'))
+    return ((fun,rhs) : rest)
 
-dsHsBind auto_scc rest (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty })
-  = dsGuarded grhss ty				`thenDs` \ body_expr ->
-    mkSelectorBinds pat body_expr		`thenDs` \ sel_binds ->
-    returnDs (sel_binds ++ rest)
+dsHsBind auto_scc rest (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }) = do
+    body_expr <- dsGuarded grhss ty
+    sel_binds <- mkSelectorBinds pat body_expr
+    return (sel_binds ++ rest)
 
 -- Note [Rules and inlining]
 -- Common special case: no type or dictionary abstraction
@@ -149,22 +149,21 @@ dsHsBind auto_scc rest (AbsBinds [] [] exports binds)
 	-- Non-recursive bindings come through this way
 dsHsBind auto_scc rest
      (AbsBinds all_tyvars dicts exports@[(tyvars, global, local, prags)] binds)
-  = ASSERT( all (`elem` tyvars) all_tyvars )
-    ds_lhs_binds NoSccs binds 	`thenDs` \ core_prs ->
-    let 
-	-- Always treat the binds as recursive, because the typechecker
-	-- makes rather mixed-up dictionary bindings
-	core_bind = Rec core_prs
-    in
-    mappM (dsSpec all_tyvars dicts tyvars global local core_bind) 
-	  prags				`thenDs` \ mb_specs ->
+  = ASSERT( all (`elem` tyvars) all_tyvars ) do
+    core_prs <- ds_lhs_binds NoSccs binds
     let
-	(spec_binds, rules) = unzip (catMaybes mb_specs)
-	global' = addIdSpecialisations global rules
-	rhs'    = mkLams tyvars $ mkLams dicts $ Let core_bind (Var local)
-	bind    = addInlinePrags prags global' $ addAutoScc auto_scc global' rhs'
-    in
-    returnDs (bind  : spec_binds ++ rest)
+        -- Always treat the binds as recursive, because the typechecker
+        -- makes rather mixed-up dictionary bindings
+        core_bind = Rec core_prs
+    
+    mb_specs <- mapM (dsSpec all_tyvars dicts tyvars global local core_bind) prags
+    let
+        (spec_binds, rules) = unzip (catMaybes mb_specs)
+        global' = addIdSpecialisations global rules
+        rhs'    = mkLams tyvars $ mkLams dicts $ Let core_bind (Var local)
+        bind    = addInlinePrags prags global' $ addAutoScc auto_scc global' rhs'
+    
+    return (bind  : spec_binds ++ rest)
 
 dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds)
   = do	{ core_prs <- ds_lhs_binds NoSccs binds
@@ -202,16 +201,16 @@ dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds)
 	                   rhs = mkLams tyvars $ mkLams dicts $
 	      	     		 mkTupleSelector locals' (locals' !! n) tup_id $
 			         mkApps (mkTyApps (Var poly_tup_id) ty_args) dict_args
-		     ; returnDs ((global', rhs) : spec_binds) }
+		     ; return ((global', rhs) : spec_binds) }
 	        where
 	          mk_ty_arg all_tyvar
 			| all_tyvar `elem` tyvars = return (mkTyVarTy all_tyvar)
 	      		| otherwise		  = dsMkArbitraryType all_tyvar
 
-	; export_binds_s <- mappM mk_bind (exports `zip` [0..])
+	; export_binds_s <- mapM mk_bind (exports `zip` [0..])
 	     -- don't scc (auto-)annotate the tuple itself.
 
-	; returnDs ((poly_tup_id, poly_tup_expr) : 
+	; return ((poly_tup_id, poly_tup_expr) : 
 		    (concat export_binds_s ++ rest)) }
 
 mkABEnv :: [([TyVar], Id, Id, [LPrag])] -> VarEnv (Id, [LPrag])
@@ -446,17 +445,17 @@ If profiling and dealing with a dict binding,
 wrap the dict in @_scc_ DICT <dict>@:
 
 \begin{code}
-addDictScc var rhs = returnDs rhs
+addDictScc var rhs = return rhs
 
 {- DISABLED for now (need to somehow make up a name for the scc) -- SDM
   | not ( opt_SccProfilingOn && opt_AutoSccsOnDicts)
     || not (isDictId var)
-  = returnDs rhs				-- That's easy: do nothing
+  = return rhs				-- That's easy: do nothing
 
   | otherwise
-  = getModuleAndGroupDs 	`thenDs` \ (mod, grp) ->
+  = do (mod, grp) <- getModuleAndGroupDs
 	-- ToDo: do -dicts-all flag (mark dict things with individual CCs)
-    returnDs (Note (SCC (mkAllDictsCC mod grp False)) rhs)
+       return (Note (SCC (mkAllDictsCC mod grp False)) rhs)
 -}
 \end{code}