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

1 files changed, 122 insertions, 129 deletions

diff --git a/compiler/deSugar/DsCCall.lhs b/compiler/deSugar/DsCCall.lhs
index abbdfb18c4..0ceb44379b 100644
--- a/compiler/deSugar/DsCCall.lhs
+++ b/compiler/deSugar/DsCCall.lhs
@@ -98,15 +98,14 @@ dsCCall :: CLabelString	-- C routine to invoke
 	-> DsM CoreExpr	-- Result, of type ???
 
 dsCCall lbl args may_gc result_ty
-  = mapAndUnzipDs unboxArg args	    `thenDs` \ (unboxed_args, arg_wrappers) ->
-    boxResult id Nothing result_ty  `thenDs` \ (ccall_result_ty, res_wrapper) ->
-    newUnique			    `thenDs` \ uniq ->
-    let
-	target = StaticTarget lbl
-	the_fcall    = CCall (CCallSpec target CCallConv may_gc)
- 	the_prim_app = mkFCall uniq the_fcall unboxed_args ccall_result_ty
-    in
-    returnDs (foldr ($) (res_wrapper the_prim_app) arg_wrappers)
+  = do (unboxed_args, arg_wrappers) <- mapAndUnzipM unboxArg args
+       (ccall_result_ty, res_wrapper) <- boxResult id Nothing result_ty
+       uniq <- newUnique
+       let
+           target = StaticTarget lbl
+           the_fcall    = CCall (CCallSpec target CCallConv may_gc)
+           the_prim_app = mkFCall uniq the_fcall unboxed_args ccall_result_ty
+       return (foldr ($) (res_wrapper the_prim_app) arg_wrappers)
 
 mkFCall :: Unique -> ForeignCall 
 	-> [CoreExpr] 	-- Args
@@ -143,7 +142,7 @@ unboxArg :: CoreExpr			-- The supplied argument
 unboxArg arg
   -- Primtive types: nothing to unbox
   | isPrimitiveType arg_ty
-  = returnDs (arg, \body -> body)
+  = return (arg, \body -> body)
 
   -- Recursive newtypes
   | Just(rep_ty, co) <- splitNewTypeRepCo_maybe arg_ty
@@ -152,26 +151,26 @@ unboxArg arg
   -- Booleans
   | Just (tc,_) <- splitTyConApp_maybe arg_ty, 
     tc `hasKey` boolTyConKey
-  = newSysLocalDs intPrimTy		`thenDs` \ prim_arg ->
-    returnDs (Var prim_arg,
-	      \ body -> Case (Case arg (mkWildId arg_ty) intPrimTy
-  		                       [(DataAlt falseDataCon,[],mkIntLit 0),
-	                                (DataAlt trueDataCon, [],mkIntLit 1)])
-					-- In increasing tag order!
+  = do prim_arg <- newSysLocalDs intPrimTy
+       return (Var prim_arg,
+              \ body -> Case (Case arg (mkWildId arg_ty) intPrimTy
+                                       [(DataAlt falseDataCon,[],mkIntLit 0),
+                                        (DataAlt trueDataCon, [],mkIntLit 1)])
+                                        -- In increasing tag order!
                              prim_arg
                              (exprType body) 
-			     [(DEFAULT,[],body)])
+                             [(DEFAULT,[],body)])
 
   -- Data types with a single constructor, which has a single, primitive-typed arg
   -- This deals with Int, Float etc; also Ptr, ForeignPtr
   | is_product_type && data_con_arity == 1 
   = ASSERT2(isUnLiftedType data_con_arg_ty1, pprType arg_ty)
-			-- Typechecker ensures this
-    newSysLocalDs arg_ty		`thenDs` \ case_bndr ->
-    newSysLocalDs data_con_arg_ty1	`thenDs` \ prim_arg ->
-    returnDs (Var prim_arg,
-	      \ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,[prim_arg],body)]
-    )
+                        -- Typechecker ensures this
+    do case_bndr <- newSysLocalDs arg_ty
+       prim_arg <- newSysLocalDs data_con_arg_ty1
+       return (Var prim_arg,
+               \ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,[prim_arg],body)]
+              )
 
   -- Byte-arrays, both mutable and otherwise; hack warning
   -- We're looking for values of type ByteArray, MutableByteArray
@@ -182,12 +181,11 @@ unboxArg arg
     maybeToBool maybe_arg3_tycon &&
     (arg3_tycon ==  byteArrayPrimTyCon ||
      arg3_tycon ==  mutableByteArrayPrimTyCon)
-  = newSysLocalDs arg_ty		`thenDs` \ case_bndr ->
-    newSysLocalsDs data_con_arg_tys	`thenDs` \ vars@[l_var, r_var, arr_cts_var] ->
-    returnDs (Var arr_cts_var,
-	      \ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,vars,body)]
-
-    )
+  = do case_bndr <- newSysLocalDs arg_ty
+       vars@[l_var, r_var, arr_cts_var] <- newSysLocalsDs data_con_arg_tys
+       return (Var arr_cts_var,
+               \ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,vars,body)]
+              )
 
   ----- Cases for .NET; almost certainly bit-rotted ---------
   | Just (tc, [arg_ty]) <- splitTyConApp_maybe arg_ty,
@@ -195,40 +193,40 @@ unboxArg arg
     Just (cc,[]) <- splitTyConApp_maybe arg_ty,
     cc == charTyCon
     -- String; dotnet only
-  = dsLookupGlobalId marshalStringName `thenDs` \ unpack_id ->
-    newSysLocalDs addrPrimTy	       `thenDs` \ prim_string ->
-    returnDs (Var prim_string,
-    	      \ body ->
-	        let
-		 io_ty = exprType body
-		 Just (_,io_arg,_) = tcSplitIOType_maybe io_ty
-		in
-	      	mkApps (Var unpack_id)
-		       [ Type io_arg
-		       , arg
-		       , Lam prim_string body
-		       ])
+  = do unpack_id <- dsLookupGlobalId marshalStringName
+       prim_string <- newSysLocalDs addrPrimTy
+       return (Var prim_string,
+               \ body ->
+                 let
+                  io_ty = exprType body
+                  Just (_,io_arg,_) = tcSplitIOType_maybe io_ty
+                 in
+                 mkApps (Var unpack_id)
+                        [ Type io_arg
+                        , arg
+                        , Lam prim_string body
+                        ])
   | Just (tc, [arg_ty]) <- splitTyConApp_maybe arg_ty,
     tyConName tc == objectTyConName
     -- Object; dotnet only
-  = dsLookupGlobalId marshalObjectName `thenDs` \ unpack_id ->
-    newSysLocalDs addrPrimTy	       `thenDs` \ prim_obj  ->
-    returnDs (Var prim_obj,
-    	      \ body ->
-	        let
-		 io_ty = exprType body
-		 Just (_,io_arg,_) = tcSplitIOType_maybe io_ty
-		in
-	      	mkApps (Var unpack_id)
-		       [ Type io_arg
-		       , arg
-		       , Lam prim_obj body
-		       ])
+  = do unpack_id <- dsLookupGlobalId marshalObjectName
+       prim_obj <- newSysLocalDs addrPrimTy
+       return (Var prim_obj,
+               \ body ->
+                 let
+                  io_ty = exprType body
+                  Just (_,io_arg,_) = tcSplitIOType_maybe io_ty
+                 in
+                 mkApps (Var unpack_id)
+                        [ Type io_arg
+                        , arg
+                        , Lam prim_obj body
+                        ])
   --------------- End of cases for .NET --------------------
 
   | otherwise
-  = getSrcSpanDs `thenDs` \ l ->
-    pprPanic "unboxArg: " (ppr l <+> ppr arg_ty)
+  = do l <- getSrcSpanDs
+       pprPanic "unboxArg: " (ppr l <+> ppr arg_ty)
   where
     arg_ty					= exprType arg
     maybe_product_type 			   	= splitProductType_maybe arg_ty
@@ -306,127 +304,122 @@ boxResult augment mbTopCon result_ty
 	; return (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap) }
 
 boxResult augment mbTopCon result_ty
-  = 	-- It isn't IO, so do unsafePerformIO
-	-- It's not conveniently available, so we inline it
-    resultWrapper result_ty            `thenDs` \ res ->
-    mk_alt return_result (augment res) `thenDs` \ (ccall_res_ty, the_alt) ->
-    let
-	wrap = \ the_call -> Case (App the_call (Var realWorldPrimId)) 
-			    	  (mkWildId ccall_res_ty)
-			          (coreAltType the_alt)
-			    	  [the_alt]
-    in
-    returnDs (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap)
+  = do -- It isn't IO, so do unsafePerformIO
+       -- It's not conveniently available, so we inline it
+       res <- resultWrapper result_ty
+       (ccall_res_ty, the_alt) <- mk_alt return_result (augment res)
+       let
+           wrap = \ the_call -> Case (App the_call (Var realWorldPrimId)) 
+                                     (mkWildId ccall_res_ty)
+                                     (coreAltType the_alt)
+                                     [the_alt]
+       return (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap)
   where
     return_result state [ans] = ans
     return_result _ _ = panic "return_result: expected single result"
 
 
 mk_alt return_result (Nothing, wrap_result)
-  = 	-- The ccall returns ()
-	  newSysLocalDs realWorldStatePrimTy	`thenDs` \ state_id ->
-	  let
-		the_rhs = return_result (Var state_id) 
-					[wrap_result (panic "boxResult")]
+  = do -- The ccall returns ()
+       state_id <- newSysLocalDs realWorldStatePrimTy
+       let
+             the_rhs = return_result (Var state_id) 
+                                     [wrap_result (panic "boxResult")]
 
-		ccall_res_ty = mkTyConApp unboxedSingletonTyCon [realWorldStatePrimTy]
-		the_alt      = (DataAlt unboxedSingletonDataCon, [state_id], the_rhs)
-	  in
-	  returnDs (ccall_res_ty, the_alt)
+             ccall_res_ty = mkTyConApp unboxedSingletonTyCon [realWorldStatePrimTy]
+             the_alt      = (DataAlt unboxedSingletonDataCon, [state_id], the_rhs)
+       
+       return (ccall_res_ty, the_alt)
 
 mk_alt return_result (Just prim_res_ty, wrap_result)
     		-- The ccall returns a non-() value
-  | isUnboxedTupleType prim_res_ty
-  = let
-	Just (_, ls) = splitTyConApp_maybe prim_res_ty
-	arity = 1 + length ls
-    in
-    mappM newSysLocalDs ls 		`thenDs` \ args_ids@(result_id:as) ->
-    newSysLocalDs realWorldStatePrimTy	`thenDs` \ state_id ->
+  | isUnboxedTupleType prim_res_ty= do
     let
-	the_rhs = return_result (Var state_id) 
-				(wrap_result (Var result_id) : map Var as)
-	ccall_res_ty = mkTyConApp (tupleTyCon Unboxed arity)
-				  (realWorldStatePrimTy : ls)
-	the_alt	     = ( DataAlt (tupleCon Unboxed arity)
-		       , (state_id : args_ids)
-		       , the_rhs
-		       )
-    in
-    returnDs (ccall_res_ty, the_alt)
-
-  | otherwise
-  = newSysLocalDs prim_res_ty 		`thenDs` \ result_id ->
-    newSysLocalDs realWorldStatePrimTy	`thenDs` \ state_id ->
+        Just (_, ls) = splitTyConApp_maybe prim_res_ty
+        arity = 1 + length ls
+    args_ids@(result_id:as) <- mapM newSysLocalDs ls
+    state_id <- newSysLocalDs realWorldStatePrimTy
+    let
+        the_rhs = return_result (Var state_id) 
+                                (wrap_result (Var result_id) : map Var as)
+        ccall_res_ty = mkTyConApp (tupleTyCon Unboxed arity)
+                                  (realWorldStatePrimTy : ls)
+        the_alt      = ( DataAlt (tupleCon Unboxed arity)
+                       , (state_id : args_ids)
+                       , the_rhs
+                       )
+    return (ccall_res_ty, the_alt)
+
+  | otherwise = do
+    result_id <- newSysLocalDs prim_res_ty
+    state_id <- newSysLocalDs realWorldStatePrimTy
     let
-	the_rhs = return_result (Var state_id) 
-				[wrap_result (Var result_id)]
-	ccall_res_ty = mkTyConApp unboxedPairTyCon [realWorldStatePrimTy, prim_res_ty]
-	the_alt	     = (DataAlt unboxedPairDataCon, [state_id, result_id], the_rhs)
-    in
-    returnDs (ccall_res_ty, the_alt)
+        the_rhs = return_result (Var state_id) 
+                                [wrap_result (Var result_id)]
+        ccall_res_ty = mkTyConApp unboxedPairTyCon [realWorldStatePrimTy, prim_res_ty]
+        the_alt      = (DataAlt unboxedPairDataCon, [state_id, result_id], the_rhs)
+    return (ccall_res_ty, the_alt)
 
 
 resultWrapper :: Type
-   	      -> DsM (Maybe Type,		-- Type of the expected result, if any
-		      CoreExpr -> CoreExpr)	-- Wrapper for the result 
+              -> DsM (Maybe Type,               -- Type of the expected result, if any
+                      CoreExpr -> CoreExpr)     -- Wrapper for the result 
 -- resultWrapper deals with the result *value*
 -- E.g. foreign import foo :: Int -> IO T
 -- Then resultWrapper deals with marshalling the 'T' part
 resultWrapper result_ty
   -- Base case 1: primitive types
   | isPrimitiveType result_ty
-  = returnDs (Just result_ty, \e -> e)
+  = return (Just result_ty, \e -> e)
 
   -- Base case 2: the unit type ()
   | Just (tc,_) <- maybe_tc_app, tc `hasKey` unitTyConKey
-  = returnDs (Nothing, \e -> Var unitDataConId)
+  = return (Nothing, \e -> Var unitDataConId)
 
   -- Base case 3: the boolean type
   | Just (tc,_) <- maybe_tc_app, tc `hasKey` boolTyConKey
-  = returnDs
+  = return
      (Just intPrimTy, \e -> Case e (mkWildId intPrimTy)
                                    boolTy
-	                           [(DEFAULT             ,[],Var trueDataConId ),
-				    (LitAlt (mkMachInt 0),[],Var falseDataConId)])
+                                   [(DEFAULT             ,[],Var trueDataConId ),
+                                    (LitAlt (mkMachInt 0),[],Var falseDataConId)])
 
   -- Recursive newtypes
   | Just (rep_ty, co) <- splitNewTypeRepCo_maybe result_ty
-  = resultWrapper rep_ty `thenDs` \ (maybe_ty, wrapper) ->
-    returnDs (maybe_ty, \e -> mkCoerce (mkSymCoercion co) (wrapper e))
+  = do (maybe_ty, wrapper) <- resultWrapper rep_ty
+       return (maybe_ty, \e -> mkCoerce (mkSymCoercion co) (wrapper e))
 
   -- The type might contain foralls (eg. for dummy type arguments,
   -- referring to 'Ptr a' is legal).
   | Just (tyvar, rest) <- splitForAllTy_maybe result_ty
-  = resultWrapper rest `thenDs` \ (maybe_ty, wrapper) ->
-    returnDs (maybe_ty, \e -> Lam tyvar (wrapper e))
+  = do (maybe_ty, wrapper) <- resultWrapper rest
+       return (maybe_ty, \e -> Lam tyvar (wrapper e))
 
   -- Data types with a single constructor, which has a single arg
   -- This includes types like Ptr and ForeignPtr
   | Just (tycon, tycon_arg_tys, data_con, data_con_arg_tys) <- splitProductType_maybe result_ty,
     dataConSourceArity data_con == 1
-  = let
-	(unwrapped_res_ty : _) = data_con_arg_tys
-	narrow_wrapper         = maybeNarrow tycon
-    in
-    resultWrapper unwrapped_res_ty `thenDs` \ (maybe_ty, wrapper) ->
-    returnDs
-      (maybe_ty, \e -> mkApps (Var (dataConWrapId data_con)) 
-			      (map Type tycon_arg_tys ++ [wrapper (narrow_wrapper e)]))
+  = do let
+           (unwrapped_res_ty : _) = data_con_arg_tys
+           narrow_wrapper         = maybeNarrow tycon
+       (maybe_ty, wrapper) <- resultWrapper unwrapped_res_ty
+       return
+         (maybe_ty, \e -> mkApps (Var (dataConWrapId data_con)) 
+                                 (map Type tycon_arg_tys ++ [wrapper (narrow_wrapper e)]))
 
     -- Strings; 'dotnet' only.
   | Just (tc, [arg_ty]) <- maybe_tc_app,               tc == listTyCon,
     Just (cc,[])        <- splitTyConApp_maybe arg_ty, cc == charTyCon
-  = dsLookupGlobalId unmarshalStringName	`thenDs` \ pack_id ->
-    returnDs (Just addrPrimTy,
-    	      \ e -> App (Var pack_id) e)
+  = do pack_id <- dsLookupGlobalId unmarshalStringName
+       return (Just addrPrimTy,
+                 \ e -> App (Var pack_id) e)
 
     -- Objects; 'dotnet' only.
   | Just (tc, [arg_ty]) <- maybe_tc_app, 
     tyConName tc == objectTyConName
-  = dsLookupGlobalId unmarshalObjectName	`thenDs` \ pack_id ->
-    returnDs (Just addrPrimTy,
-    	      \ e -> App (Var pack_id) e)
+  = do pack_id <- dsLookupGlobalId unmarshalObjectName
+       return (Just addrPrimTy,
+                 \ e -> App (Var pack_id) e)
 
   | otherwise
   = pprPanic "resultWrapper" (ppr result_ty)