partially monomorphise & de-generify Env

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

@@ -14,13 +14,11 @@ import           Data.ByteString as BS (ByteString)
 import           Data.ByteString.Base16 as Base16
 import           Data.DList (DList)
 import qualified Data.DList as DL
-import           Data.Dependent.Sum ((==>))
 import           Data.Text (Text)
 import qualified Data.Text as Text
 
 import           Cardano.Api
-import           Cardano.Benchmarking.Script.Setters
-import           Cardano.Benchmarking.Script.Store (KeyName, Name (..), WalletName)
+import           Cardano.Benchmarking.Script.Store
 import           Cardano.Benchmarking.Script.Types
 import           Cardano.TxGenerator.Setup.NixService
 import           Cardano.TxGenerator.Types (TxGenTxParams (..))
@@ -67,18 +65,13 @@ compileToScript = do
 
 initConstants :: Compiler ()
 initConstants = do
-  setN TLocalSocket          _nix_localNodeSocketPath
+  p <- askNixOption _nix_localNodeSocketPath
+  emit $ SetSocketPath p
   emit $ DefineSigningKey keyNameTxGenFunds keyTxGenFunds
   emit $ DefineSigningKey keyNameCollaterals keyCollaterals
   emit $ DefineSigningKey keyNameSplitPhase keySplitPhase
   emit $ DefineSigningKey keyNameBenchmarkInputs keyBenchmarkInputs
   emit $ DefineSigningKey keyNameBenchmarkDone keyBenchmarkDone
-  where
-    setConst :: Tag v -> v -> Compiler ()
-    setConst key val = emit $ Set $ key ==> val
-
-    setN :: Tag v -> (NixServiceOptions -> v) -> Compiler ()
-    setN key s = askNixOption s >>= setConst key
 
 importGenesisFunds :: Compiler WalletName
 importGenesisFunds = do

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

@@ -1,8 +1,8 @@
+{-# LANGUAGE GADTs #-}
+
 module Cardano.Benchmarking.Script.Action
 where
 
-import           Data.Functor.Identity
-import           Data.Dependent.Sum (DSum(..))
 import qualified Data.Text as Text (unpack)
 
 import           Cardano.Benchmarking.Script.Core
@@ -13,7 +13,8 @@ import           Cardano.Benchmarking.Script.Types
 
 action :: Action -> ActionM ()
 action a = case a of
-  Set (key :=> (Identity val)) -> set (User key) val
+  SetNetworkId val -> set SNetworkId val
+  SetSocketPath val -> set SSocketPath val
   InitWallet name -> initWallet name
   SetProtocolParameters p -> setProtocolParameters p
   StartProtocol configFile cardanoTracerSocket -> startProtocol configFile cardanoTracerSocket

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

@@ -11,8 +11,6 @@ where
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Char8 as BS (lines)
 import qualified Data.ByteString.Lazy as BSL
-import           Data.Dependent.Sum
-import           Data.Functor.Identity
 import           Data.Text (Text)
 import           GHC.Generics (Generic)
 import           Prelude
@@ -29,7 +27,6 @@ import           Cardano.Api.Shelley (ProtocolParameters)
 import           Cardano.CLI.Types (SigningKeyFile (..))
 import qualified Ouroboros.Network.Magic as Ouroboros (NetworkMagic (..))
 
-import           Cardano.Benchmarking.Script.Setters
 import           Cardano.Benchmarking.Script.Store
 import           Cardano.Benchmarking.Script.Types
 import           Cardano.TxGenerator.Types
@@ -107,17 +104,6 @@ instance ToJSON ScriptSpec where
 instance FromJSON ScriptSpec where
   parseJSON = genericParseJSON jsonOptionsUnTaggedSum
 
-instance ToJSON (DSum Tag Identity) where
-  toJSON     = toJSON . taggedToSum
-instance FromJSON (DSum Tag Identity) where
-  parseJSON a = sumToTagged <$> parseJSON a
-
-instance ToJSON Sum where
-  toJSON     = genericToJSON jsonOptionsUnTaggedSum
-  toEncoding = genericToEncoding jsonOptionsUnTaggedSum
-instance FromJSON Sum where
-  parseJSON = genericParseJSON jsonOptionsUnTaggedSum
-
 instance ToJSON Action where
   toJSON     = genericToJSON jsonOptionsUnTaggedSum
   toEncoding = genericToEncoding jsonOptionsUnTaggedSum

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

@@ -63,7 +63,6 @@ import           Cardano.Benchmarking.Wallet as Wallet
 import           Cardano.Benchmarking.Script.Aeson (readProtocolParametersFile)
 import           Cardano.Benchmarking.Script.Env hiding (Error (TxGenError))
 import qualified Cardano.Benchmarking.Script.Env as Env (Error (TxGenError))
-import           Cardano.Benchmarking.Script.Setters
 import           Cardano.Benchmarking.Script.Store as Store
 import           Cardano.Benchmarking.Script.Types
 import           Cardano.Benchmarking.Version as Version
@@ -84,16 +83,16 @@ withEra era action = do
 setProtocolParameters :: ProtocolParametersSource -> ActionM ()
 setProtocolParameters s = case s of
   QueryLocalNode -> do
-    set ProtocolParameterMode ProtocolParameterQuery
+    setProtoParamMode ProtocolParameterQuery
   UseLocalProtocolFile file -> do
     protocolParameters <- liftIO $ readProtocolParametersFile file
-    set ProtocolParameterMode $ ProtocolParameterLocal protocolParameters
+    setProtoParamMode $ ProtocolParameterLocal protocolParameters
 
 readSigningKey :: KeyName -> SigningKeyFile -> ActionM ()
 readSigningKey name filePath =
   liftIO ( runExceptT $ GeneratorTx.readSigningKey filePath) >>= \case
     Left err -> liftTxGenError err
-    Right key -> setName name key
+    Right key -> set name key
 
 parseSigningKey :: TextEnvelope -> Either TextEnvelopeError (SigningKey PaymentKey)
 parseSigningKey = deserialiseFromTextEnvelopeAnyOf types
@@ -107,12 +106,12 @@ parseSigningKey = deserialiseFromTextEnvelopeAnyOf types
 defineSigningKey :: KeyName -> TextEnvelope -> ActionM ()
 defineSigningKey name descr
   = case parseSigningKey descr of
-    Right key -> setName name key
+    Right key -> set name key
     Left err -> liftTxGenError $ ApiError err
 
 addFund :: AnyCardanoEra -> WalletName -> TxIn -> Lovelace -> KeyName -> ActionM ()
 addFund era wallet txIn lovelace keyName = do
-  fundKey  <- getName keyName
+  fundKey  <- get keyName
   let
     mkOutValue :: forall era. IsShelleyBasedEra era => AsType era -> ActionM (InAnyCardanoEra TxOutValue)
     mkOutValue = \_ -> return $ InAnyCardanoEra (cardanoEra @era) (lovelaceToTxOutValue lovelace)
@@ -121,7 +120,7 @@ addFund era wallet txIn lovelace keyName = do
 
 addFundToWallet :: WalletName -> TxIn -> InAnyCardanoEra TxOutValue -> SigningKey PaymentKey -> ActionM ()
 addFundToWallet wallet txIn outVal skey = do
-  walletRef <- getName wallet
+  walletRef <- get wallet
   liftIO (walletRefInsertFund walletRef (FundQueue.Fund $ mkFund outVal))
   where
     mkFund = Utils.liftAnyEra $ \value -> FundInEra {
@@ -146,7 +145,7 @@ waitBenchmarkCore ctl = do
 getConnectClient :: ActionM ConnectClient
 getConnectClient = do
   tracers  <- get BenchTracers
-  (Testnet networkMagic) <- getUser TNetworkId
+  (Testnet networkMagic) <- get SNetworkId
   protocol <- get Protocol
   void $ return $(btSubmission2_ tracers)
   ioManager <- askIOManager
@@ -157,16 +156,16 @@ getConnectClient = do
                        (protocolToCodecConfig protocol)
                        networkMagic
 waitBenchmark :: ThreadName -> ActionM ()
-waitBenchmark n = getName n >>= waitBenchmarkCore
+waitBenchmark n = get n >>= waitBenchmarkCore
 
 cancelBenchmark :: ThreadName -> ActionM ()
 cancelBenchmark n = do
-  ctl@(_, _ , _ , shutdownAction) <- getName n
+  ctl@(_, _ , _ , shutdownAction) <- get n
   liftIO shutdownAction
   waitBenchmarkCore ctl
 
 getLocalConnectInfo :: ActionM  (LocalNodeConnectInfo CardanoMode)
-getLocalConnectInfo = makeLocalConnectInfo <$> getUser TNetworkId <*> getUser TLocalSocket
+getLocalConnectInfo = makeLocalConnectInfo <$> get SNetworkId <*> get SSocketPath
 
 queryEra :: ActionM AnyCardanoEra
 queryEra = do
@@ -200,7 +199,7 @@ queryRemoteProtocolParameters = do
 
 getProtocolParameters :: ActionM ProtocolParameters
 getProtocolParameters = do
-  get ProtocolParameterMode  >>= \case
+  getProtoParamMode  >>= \case
     ProtocolParameterQuery -> queryRemoteProtocolParameters
     ProtocolParameterLocal parameters -> return parameters
 
@@ -283,18 +282,18 @@ benchmarkTxStream txStream targetNodes (ThreadName threadName) tps txCount era =
   ret <- liftIO $ runExceptT $ coreCall era
   case ret of
     Left err -> liftTxGenError err
-    Right ctl -> setName (ThreadName threadName) ctl
+    Right ctl -> set (ThreadName threadName) ctl
 
 evalGenerator :: forall era. IsShelleyBasedEra era => Generator -> TxGenTxParams -> AsType era -> ActionM (TxStream IO era)
 evalGenerator generator txParams@TxGenTxParams{txParamFee = fee} era = do
-  networkId <- getUser TNetworkId
+  networkId <- get SNetworkId
   protocolParameters <- getProtocolParameters
   case generator of
     SecureGenesis wallet genesisKeyName destKeyName -> do
       genesis  <- get Genesis
-      destKey  <- getName destKeyName
-      destWallet  <- getName wallet
-      genesisKey  <- getName genesisKeyName
+      destKey  <- get destKeyName
+      destWallet  <- get wallet
+      genesisKey  <- get genesisKeyName
       (tx, fund) <- firstExceptT Env.TxGenError $ hoistEither $
         Genesis.genesisSecureInitialFund networkId genesis genesisKey destKey txParams
       let
@@ -303,7 +302,7 @@ evalGenerator generator txParams@TxGenTxParams{txParamFee = fee} era = do
           return $ Right tx
       return $ Streaming.effect (Streaming.yield <$> gen)
     Split walletName payMode payModeChange coins -> do
-      wallet <- getName walletName
+      wallet <- get walletName
       (toUTxO, addressOut) <- interpretPayMode payMode
       traceDebug $ "split output address : " ++ addressOut
       (toUTxOChange, addressChange) <- interpretPayMode payModeChange
@@ -315,7 +314,7 @@ evalGenerator generator txParams@TxGenTxParams{txParamFee = fee} era = do
         sourceToStore = sourceToStoreTransactionNew txGenerator fundSource inToOut $ mangleWithChange toUTxOChange toUTxO
       return $ Streaming.effect (Streaming.yield <$> sourceToStore)
     SplitN walletName payMode count -> do
-      wallet <- getName walletName
+      wallet <- get walletName
       (toUTxO, addressOut) <- interpretPayMode payMode
       traceDebug $ "SplitN output address : " ++ addressOut
       let
@@ -326,7 +325,7 @@ evalGenerator generator txParams@TxGenTxParams{txParamFee = fee} era = do
       return $ Streaming.effect (Streaming.yield <$> sourceToStore)
 
     NtoM walletName payMode inputs outputs metadataSize collateralWallet -> do
-      wallet <- getName walletName
+      wallet <- get walletName
       collaterals <- selectCollateralFunds collateralWallet
       (toUTxO, addressOut) <- interpretPayMode payMode
       traceDebug $ "NtoM output address : " ++ addressOut
@@ -353,7 +352,7 @@ selectCollateralFunds :: forall era. IsShelleyBasedEra era
   -> ActionM (TxInsCollateral era, [FundQueue.Fund])
 selectCollateralFunds Nothing = return (TxInsCollateralNone, [])
 selectCollateralFunds (Just walletName) = do
-  cw <- getName walletName
+  cw <- get walletName
   collateralFunds <- liftIO ( askWalletRef cw FundQueue.toList ) >>= \case
     [] -> throwE $ WalletError "selectCollateralFunds: emptylist"
     l -> return l
@@ -368,19 +367,19 @@ dumpToFileIO :: FilePath -> TxInMode CardanoMode -> IO ()
 dumpToFileIO filePath tx = appendFile filePath ('\n' : show tx)
 
 initWallet :: WalletName -> ActionM ()
-initWallet name = liftIO Wallet.initWallet >>= setName name
+initWallet name = liftIO Wallet.initWallet >>= set name
 
 interpretPayMode :: forall era. IsShelleyBasedEra era => PayMode -> ActionM (CreateAndStore IO era, String)
 interpretPayMode payMode = do
-  networkId <- getUser TNetworkId
+  networkId <- get SNetworkId
   case payMode of
     PayToAddr keyName destWallet -> do
-      fundKey <- getName keyName
-      walletRef <- getName destWallet
+      fundKey <- get keyName
+      walletRef <- get destWallet
       return ( createAndStore (mkUTxOVariant networkId fundKey) (mkWalletFundStore walletRef)
              , Text.unpack $ serialiseAddress $ Utils.keyAddress @era networkId fundKey)
     PayToScript scriptSpec destWallet -> do
-      walletRef <- getName destWallet
+      walletRef <- get destWallet
       (witness, script, scriptData, _scriptFee) <- makePlutusContext scriptSpec
       return ( createAndStore (mkUTxOScript networkId (script, scriptData) witness) (mkWalletFundStore walletRef)
                , Text.unpack $ serialiseAddress $ makeShelleyAddress networkId (PaymentCredentialByScript $ hashScript script) NoStakeAddress )

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

@@ -10,13 +10,25 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UndecidableInstances #-}
 
-module Cardano.Benchmarking.Script.Env
-where
+module Cardano.Benchmarking.Script.Env (
+        ActionM
+        , Error(..)
+        , runActionM
+        , runActionMEnv
+        , liftTxGenError
+        , askIOManager
+        , traceDebug
+        , traceError
+        , traceBenchTxSubmit
+        , getProtoParamMode
+        , setProtoParamMode
+        , get
+        , set
+) where
 
 import           Prelude
 import           Data.Functor.Identity
 import qualified Data.Text as Text
-import           Data.Dependent.Sum (DSum(..))
 import           Data.Dependent.Map (DMap)
 import qualified Data.Dependent.Map as DMap
 import           Control.Monad.IO.Class
@@ -28,15 +40,16 @@ import           "contra-tracer" Control.Tracer (traceWith)
 
 import qualified Cardano.Benchmarking.LogTypes as Tracer
 import           Ouroboros.Network.NodeToClient (IOManager)
+import           Cardano.Benchmarking.Script.Store
 
 import           Cardano.TxGenerator.Types (TxGenError(..))
-import           Cardano.Benchmarking.Script.Setters as Setters
-import           Cardano.Benchmarking.Script.Store
 
-type Env = DMap Store Identity
+data Env = Env { dmap :: DMap Store Identity
+               , protoParams :: Maybe ProtocolParameterMode
+               }
 
 emptyEnv :: Env
-emptyEnv = DMap.empty
+emptyEnv = Env { dmap = DMap.empty, protoParams = Nothing }
 
 type ActionM a = ExceptT Error (RWST IOManager () Env IO) a
 
@@ -46,8 +59,6 @@ runActionM = runActionMEnv emptyEnv
 runActionMEnv :: Env -> ActionM ret -> IOManager -> IO (Either Error ret, Env, ())
 runActionMEnv env action iom = RWS.runRWST (runExceptT action) iom env
 
-type SetKeyVal = DSum Setters.Tag Identity
-
 data Error where
   LookupError :: !(Store v)  -> Error
   TxGenError  :: !TxGenError -> Error
@@ -64,31 +75,22 @@ askIOManager :: ActionM IOManager
 askIOManager = lift RWS.ask
 
 set :: Store v -> v -> ActionM ()
-set key val = lift $ RWS.modify $ DMap.insert key (pure val)
+set key val = lift $ RWS.modify $ (\e -> e { dmap = DMap.insert key (pure val) (dmap e)})
 
-unSet :: Store v -> ActionM ()
-unSet key = lift $ RWS.modify $ DMap.delete key
-
-setName :: Name v -> v -> ActionM ()
-setName = set . Named
+setProtoParamMode :: ProtocolParameterMode -> ActionM ()
+setProtoParamMode val = lift $ RWS.modify $ (\e -> e { protoParams = pure val })
 
 get :: Store v -> ActionM v
 get key = do
-  lift (RWS.gets $ DMap.lookup key) >>= \case
+  lift (RWS.gets $ (\e -> DMap.lookup key $ dmap e)) >>= \case
     Just (Identity v) -> return v
     Nothing -> throwE $ LookupError key
 
-getName :: Name v -> ActionM v
-getName = get . Named
-
-getUser :: Tag v -> ActionM v
-getUser = get . User
-
-consumeName :: Name v -> ActionM v
-consumeName n = do
-  v <- getName n
-  unSet $ Named n
-  return v
+getProtoParamMode :: ActionM ProtocolParameterMode
+getProtoParamMode = do
+  lift (RWS.gets $ (\e -> protoParams e)) >>= \case
+    Just x -> return x
+    Nothing -> throwE $ UserError "Unset ProtocolParams"
 
 traceBenchTxSubmit :: (forall txId. x -> Tracer.TraceBenchTxSubmit txId) -> x -> ActionM ()
 traceBenchTxSubmit tag msg = do

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

@@ -11,7 +11,6 @@ import           Control.Monad.Trans.Except.Extra
 
 import           Cardano.Benchmarking.OuroborosImports as Core (getGenesis, protocolToNetworkId)
 import           Cardano.Benchmarking.Script.Env
-import           Cardano.Benchmarking.Script.Setters
 import           Cardano.Benchmarking.Script.Store as Store
 import           Cardano.Benchmarking.Tracer
 
@@ -29,7 +28,7 @@ startProtocol configFile tracerSocket = do
   set Protocol protocol
   set Genesis $ Core.getGenesis protocol
   let networkId = protocolToNetworkId protocol
-  set (User TNetworkId) networkId
+  set SNetworkId networkId
   tracers <- case tracerSocket of
     Nothing -> liftIO initDefaultTracers
     Just socket -> do