Revert Tx.hs monadic cleanup

A regression was traced down to this change. The cleanup can
probably wait.

Author: NadiaYvette

bench/tx-generator/src/Cardano/Benchmarking/Script/Action.hs

@@ -3,8 +3,8 @@
 Module      : Cardano.Benchmarking.Script.Action
 Description : Convert an 'Action' to a monadic 'ActionM'.
 
-This is just exporting 'action' in order to avoid circular
-module dependencies.
+This is just exporting 'action', and 'liftToAction' is tough
+to use because of the risk of circular imports.
 -}
 
 module Cardano.Benchmarking.Script.Action
@@ -16,13 +16,15 @@ module Cardano.Benchmarking.Script.Action
 import qualified Data.Text as Text (unpack)
 
 import           Control.Monad.IO.Class
+import           Control.Monad.Trans.Except.Extra
 
 import           Cardano.Benchmarking.OuroborosImports as Core (protocolToNetworkId)
 import           Cardano.Benchmarking.Script.Core
 import           Cardano.Benchmarking.Script.Env
 import           Cardano.Benchmarking.Script.Types
 import           Cardano.Benchmarking.Tracer
 import           Cardano.TxGenerator.Setup.NodeConfig
+import           Cardano.TxGenerator.Types (TxGenError)
 
 
 -- | 'action' has as its sole callers
@@ -51,6 +53,12 @@ action a = case a of
   LogMsg txt -> traceDebug $ Text.unpack txt
   Reserved options -> reserved options
 
+-- | 'liftToAction' first lifts from IO, then converts an 'Either'
+-- to an 'Control.Monad.Trans.Except.ExceptT' and then transforms
+-- the error type to 'Cardano.Benchmarking.Script.Env.Error'.
+liftToAction :: IO (Either TxGenError a) -> ActionM a
+liftToAction = firstExceptT TxGenError . newExceptT . liftIO
+
 -- | 'startProtocol' sets up the protocol for the transaction
 -- generator from the first argument, @configFile@ and optionally
 -- traces to the second, @tracerSocket@.

bench/tx-generator/src/Cardano/Benchmarking/Script/Core.hs

@@ -310,14 +310,14 @@ evalGenerator generator txParams@TxGenTxParams{txParamFee = fee} era = do
       (toUTxOChange, addressChange) <- interpretPayMode payModeChange
       traceDebug $ "split change address : " ++ addressChange
       let
-        inToOut = return . Utils.includeChange fee coins
+        fundSource = walletSource wallet 1
+        inToOut = Utils.includeChange fee coins
         txGenerator = genTx (cardanoEra @era) protocolParameters (TxInsCollateralNone, []) feeInEra TxMetadataNone
-      inputFunds <- liftToAction $ walletSource wallet 1
-      sourceToStore <- withTxGenError . sourceToStoreTransactionNew txGenerator inputFunds inToOut $ mangleWithChange (liftIOCreateAndStore toUTxOChange) (liftIOCreateAndStore toUTxO)
-      return . Streaming.effect . pure . Streaming.yield $ Right sourceToStore
+        sourceToStore = sourceToStoreTransactionNew txGenerator fundSource inToOut $ mangleWithChange toUTxOChange toUTxO
+      return $ Streaming.effect (Streaming.yield <$> sourceToStore)
 
     -- The 'SplitN' case's call chain is somewhat elaborate.
-    -- The division is done in 'Utils.inputsToOutputsWithFee' 
+    -- The division is done in 'Utils.inputsToOutputsWithFee'
     -- but things are threaded through
     -- 'Cardano.Benchmarking.Wallet.mangle' and packed into
     -- the transaction assembled by 'sourceToStoreTransactionNew'.
@@ -326,39 +326,37 @@ evalGenerator generator txParams@TxGenTxParams{txParamFee = fee} era = do
       (toUTxO, addressOut) <- interpretPayMode payMode
       traceDebug $ "SplitN output address : " ++ addressOut
       let
-        inToOut = withExceptT TxGenError . Utils.inputsToOutputsWithFee fee count
+        fundSource = walletSource wallet 1
+        inToOut = Utils.inputsToOutputsWithFee fee count
         txGenerator = genTx (cardanoEra @era) protocolParameters (TxInsCollateralNone, []) feeInEra TxMetadataNone
-      inputFunds <- liftToAction $ walletSource wallet 1
-      sourceToStore <- withTxGenError $ sourceToStoreTransactionNew txGenerator inputFunds inToOut (mangle . repeat $ liftIOCreateAndStore toUTxO)
-      return . Streaming.effect . pure . Streaming.yield $ Right sourceToStore
+        sourceToStore = sourceToStoreTransactionNew txGenerator fundSource inToOut (mangle $ repeat toUTxO)
+      return $ Streaming.effect (Streaming.yield <$> sourceToStore)
 
     NtoM walletName payMode inputs outputs metadataSize collateralWallet -> do
       wallet <- getEnvWallets walletName
       collaterals <- selectCollateralFunds collateralWallet
       (toUTxO, addressOut) <- interpretPayMode payMode
       traceDebug $ "NtoM output address : " ++ addressOut
       let
-        inToOut = withExceptT TxGenError . Utils.inputsToOutputsWithFee fee outputs
+        fundSource = walletSource wallet inputs
+        inToOut = Utils.inputsToOutputsWithFee fee outputs
         txGenerator = genTx (cardanoEra @era) protocolParameters collaterals feeInEra (toMetadata metadataSize)
-        previewCatcher err = do
-          traceDebug $ "Error creating Tx preview: " ++ show err
-          throwE err
-      inputFunds <- liftToAction $ walletSource wallet inputs
-      sourceToStore <- withTxGenError $ sourceToStoreTransactionNew txGenerator inputFunds inToOut (mangle . repeat $ liftIOCreateAndStore toUTxO)
+        sourceToStore = sourceToStoreTransactionNew txGenerator fundSource inToOut (mangle $ repeat toUTxO)
 
       fundPreview <- liftIO $ walletPreview wallet inputs
-      preview <- withTxGenError (sourceTransactionPreview txGenerator fundPreview inToOut (mangle . repeat $ liftIOCreateAndStore toUTxO))
-                   `catchE` previewCatcher
-      let txSize = txSizeInBytes preview
-      traceDebug $ "Projected Tx size in bytes: " ++ show txSize
-      summary_ <- getEnvSummary
-      forM_ summary_ $ \summary -> do
-        let summary' = summary {projectedTxSize = Just txSize}
-        setEnvSummary summary'
-        traceBenchTxSubmit TraceBenchPlutusBudgetSummary summary'
-      dumpBudgetSummaryIfExisting
-
-      return . Streaming.effect . pure . Streaming.yield $ Right sourceToStore
+      case sourceTransactionPreview txGenerator fundPreview inToOut (mangle $ repeat toUTxO) of
+        Left err -> traceDebug $ "Error creating Tx preview: " ++ show err
+        Right tx -> do
+          let txSize = txSizeInBytes tx
+          traceDebug $ "Projected Tx size in bytes: " ++ show txSize
+          summary_ <- getEnvSummary
+          forM_ summary_ $ \summary -> do
+            let summary' = summary {projectedTxSize = Just txSize}
+            setEnvSummary summary'
+            traceBenchTxSubmit TraceBenchPlutusBudgetSummary summary'
+          dumpBudgetSummaryIfExisting
+
+      return $ Streaming.effect (Streaming.yield <$> sourceToStore)
 
     Sequence l -> do
       gList <- forM l $ \g -> evalGenerator g txParams era
@@ -376,10 +374,6 @@ evalGenerator generator txParams@TxGenTxParams{txParamFee = fee} era = do
 
   where
     feeInEra = Utils.mkTxFee fee
-    -- 'liftIOCreateAndStore' is supposed to be some indication that 'liftIO'
-    -- is applied to a 'CreateAndStore'.
-    -- This could be golfed as @((liftIO .) .)@ but it's unreadable.
-    liftIOCreateAndStore cas = second (\f x y -> liftIO (f x y)) . cas
 
 selectCollateralFunds :: forall era. IsShelleyBasedEra era
   => Maybe String
@@ -403,8 +397,6 @@ dumpToFileIO filePath tx = appendFile filePath ('\n' : show tx)
 initWallet :: String -> ActionM ()
 initWallet name = liftIO Wallet.initWallet >>= setEnvWallets name
 
--- The inner monad being 'IO' creates some programming overhead above.
--- Something like 'MonadIO' would be helpful, but the typing is tricky.
 interpretPayMode :: forall era. IsShelleyBasedEra era => PayMode -> ActionM (CreateAndStore IO era, String)
 interpretPayMode payMode = do
   networkId <- getEnvNetworkId

bench/tx-generator/src/Cardano/Benchmarking/Script/Env.hs

@@ -30,10 +30,8 @@ module Cardano.Benchmarking.Script.Env (
         , Error(..)
         , runActionM
         , runActionMEnv
-        , liftToAction
         , liftTxGenError
         , liftIOSafe
-        , withTxGenError
         , askIOManager
         , traceDebug
         , traceError
@@ -133,7 +131,7 @@ runActionM = runActionMEnv emptyEnv
 runActionMEnv :: Env -> ActionM ret -> IOManager -> IO (Either Error ret, Env, ())
 runActionMEnv env action iom = RWS.runRWST (runExceptT action) iom env
 
--- | 'Error' adds two cases to 'Cardano.TxGenerator.Types.TxGenError' 
+-- | 'Error' adds two cases to 'Cardano.TxGenerator.Types.TxGenError'
 -- which in turn wraps 'Cardano.Api.Error' implicit contexts to a
 -- couple of its constructors. These represent errors that might arise
 -- in the execution of a transaction with some distinctions as to the
@@ -150,17 +148,6 @@ data Error where
 
 deriving instance Show Error
 
--- | This abbreviates access to the fully-qualified constructor name
--- for `Cardano.Benchmarking.Script.Env.TxGenError` and the repetitive
--- usage of `withExceptT` with that as its first argument.
-withTxGenError :: Monad m => ExceptT TxGenError m a -> ExceptT Error m a
-withTxGenError = withExceptT Cardano.Benchmarking.Script.Env.TxGenError
-
--- | This injects an `IO` action using `Either` as hand-rolled
--- exceptions into the `ActionM` monad.
-liftToAction :: IO (Either TxGenError a) -> ActionM a
-liftToAction = withTxGenError . ExceptT . liftIO
-
 -- | This throws a `TxGenError` in the `ActionM` monad.
 liftTxGenError :: TxGenError -> ActionM a
 liftTxGenError = throwE . Cardano.Benchmarking.Script.Env.TxGenError

bench/tx-generator/src/Cardano/Benchmarking/Script/Types.hs

@@ -98,7 +98,7 @@ data Action where
   AddFund            :: !AnyCardanoEra -> !String -> !TxIn -> !Lovelace -> !String -> Action
   -- | 'WaitBenchmark' signifies a 'Control.Concurrent.Async.waitCatch'
   -- on the 'Cardano.Benchmarking.GeneratorTx.AsyncBenchmarkControl'
-  -- associated with the ID and also folds tracers into the completion. 
+  -- associated with the ID and also folds tracers into the completion.
   WaitBenchmark      :: !String -> Action
   -- | 'Submit' mostly wraps
   -- 'Cardano.Benchamrking.Script.Core.benchmarkTxStream'
@@ -108,7 +108,7 @@ data Action where
   -- 'Cardano.Benchmarking.GeneratorTx.SubmissionClient.txSubmissionClient'
   -- and functions local to that like @requestTxs@.
   Submit             :: !AnyCardanoEra -> !SubmitMode -> !TxGenTxParams -> !Generator -> Action
-  -- | 'CancelBenchmark' wraps a callback from the 
+  -- | 'CancelBenchmark' wraps a callback from the
   -- 'Cardano.Benchmarking.GeneratorTx.AsyncBenchmarkControl' type,
   -- which is a shutdown action.
   CancelBenchmark    :: !String -> Action

bench/tx-generator/src/Cardano/Benchmarking/Types.hs

@@ -10,8 +10,8 @@ module Cardano.Benchmarking.Types
   ( module Cardano.Benchmarking.Types
   ) where
 
-import           GHC.Generics (Generic)
 import           Data.Aeson (ToJSON)
+import           GHC.Generics (Generic)
 
 
 -- | Transactions we decided to announce now.

bench/tx-generator/src/Cardano/Benchmarking/Wallet.hs

@@ -13,14 +13,14 @@ module Cardano.Benchmarking.Wallet
 where
 import           Prelude
 
-import           Streaming
 import           Control.Concurrent.MVar
+import           Streaming
 
 import           Cardano.Api
 
 import           Cardano.TxGenerator.FundQueue as FundQueue
-import           Cardano.TxGenerator.Types
 import           Cardano.TxGenerator.Tx
+import           Cardano.TxGenerator.Types
 import           Cardano.TxGenerator.UTxO
 
 -- | All the actual functionality of Wallet / WalletRef has been removed
@@ -122,10 +122,10 @@ mangleWithChange mkChange mkPayment outs = case outs of
 -- as the first @fkts@ argument is 'mangleWithChange' above. This
 -- is likely worth refactoring for the sake of maintainability.
 mangle :: Monad m => [ CreateAndStore m era ] -> CreateAndStoreList m era [ Lovelace ]
-mangle fkts values 
+mangle fkts values
   = (outs, \txId -> mapM_ (\f -> f txId) fs)
   where
-    (outs, fs) = unzip $ zipWith3 worker fkts values [TxIx 0 ..]
-    worker toUTxO value idx
+    (outs, fs) = unzip $ map worker $ zip3 fkts values [TxIx 0 ..]
+    worker (toUTxO, value, idx)
       = let (o, f ) = toUTxO value
-         in  (o, f idx) 
+         in  (o, f idx)

bench/tx-generator/src/Cardano/TxGenerator/PureExample.hs

@@ -1,5 +1,4 @@
 {-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
 
@@ -8,10 +7,8 @@ module  Cardano.TxGenerator.PureExample
         where
 
 import           Control.Monad (foldM)
-import           Control.Monad.Trans.Except
 import           Control.Monad.Trans.State.Strict
 import           Data.Either (fromRight)
-import           Data.Functor.Identity (runIdentity)
 import           Data.List (foldl')
 import           Data.String (fromString)
 import           System.Exit (die)
@@ -95,16 +92,13 @@ type Generator = State FundQueue
 generateTx ::
      TxEnvironment BabbageEra
   -> Generator (Either TxGenError (Tx BabbageEra))
-generateTx TxEnvironment{..} = do
-  funds' <- consumeInputFunds
-  case funds' of
-    Left err -> pure $ Left err
-    Right funds -> runExceptT $ sourceToStoreTransaction
-                                    generator
-                                    funds
-                                    computeOutputValues
-                                    (makeToUTxOList $ repeat computeUTxO)
-                                    addNewOutputFunds
+generateTx TxEnvironment{..}
+  = sourceToStoreTransaction
+        generator
+        consumeInputFunds
+        computeOutputValues
+        (makeToUTxOList $ repeat computeUTxO)
+        addNewOutputFunds
   where
     TxFeeExplicit _ fee = txEnvFee
 
@@ -125,8 +119,8 @@ generateTx TxEnvironment{..} = do
     addNewOutputFunds :: [Fund] -> Generator ()
     addNewOutputFunds = put . foldl' insertFund emptyFundQueue
 
-    computeOutputValues :: Monad m => [Lovelace] -> ExceptT TxGenError m [Lovelace]
-    computeOutputValues = withExceptT TxGenError . inputsToOutputsWithFee fee numOfOutputs
+    computeOutputValues :: [Lovelace] -> [Lovelace]
+    computeOutputValues = inputsToOutputsWithFee fee numOfOutputs
       where numOfOutputs = 2
 
     computeUTxO = mkUTxOVariant txEnvNetworkId signingKey
@@ -148,8 +142,6 @@ generateTxPure ::
   -> Either TxGenError (Tx BabbageEra, FundQueue)
 generateTxPure TxEnvironment{..} inQueue
   = do
-      outValues <- runIdentity . runExceptT . withExcept TxGenError . computeOutputValues $ map getFundLovelace inputs
-      let (outputs, toFunds) = makeToUTxOList (repeat computeUTxO) outValues
       (tx, txId) <- generator inputs outputs
       let outQueue = foldl' insertFund emptyFundQueue (toFunds txId)
       pure (tx, outQueue)
@@ -164,7 +156,10 @@ generateTxPure TxEnvironment{..} inQueue
         collateralFunds :: (TxInsCollateral BabbageEra, [Fund])
         collateralFunds = (TxInsCollateralNone, [])
 
-    computeOutputValues :: Monad m => [Lovelace] -> ExceptT String m [Lovelace]
+    outValues = computeOutputValues $ map getFundLovelace inputs
+    (outputs, toFunds) = makeToUTxOList (repeat computeUTxO) outValues
+
+    computeOutputValues :: [Lovelace] -> [Lovelace]
     computeOutputValues = inputsToOutputsWithFee fee numOfOutputs
       where numOfOutputs = 2