tweak(monad): lenses in StrategyEnvironment accessors

src/ATrade/Driver/Backtest.hs

@@ -20,7 +20,8 @@ import           ATrade.Quotes.Finam      as QF
 import           ATrade.RoboCom.Monad     (Event (..), EventCallback,
                                            MonadRobot (..), StrategyAction (..),
                                            StrategyEnvironment (..),
-                                           appendToLog, runStrategyElement, st)
+                                           appendToLog, runStrategyElement,
+                                           seBars, seLastTimestamp, st)
 import           ATrade.RoboCom.Positions
 import           ATrade.RoboCom.Types     (BarSeries (..), Ticker (..),
                                            Timeframe (..))
@@ -28,6 +29,7 @@ import           ATrade.Types
 import           Conduit                  (awaitForever, runConduit, yield,
                                            (.|))
 import           Control.Exception.Safe
+import           Control.Lens
 import           Control.Monad.ST         (runST)
 import           Control.Monad.State
 import           Data.Aeson               (FromJSON (..), Result (..),
@@ -162,9 +164,8 @@ backtestMain dataDownloadDelta defaultState initCallback callback = do
 
     backtestLoop = awaitForever (\bar -> do
       env <- gets strategyEnvironment
-      let oldTimestamp = seLastTimestamp env
       let newTimestamp = barTimestamp bar
-      let newenv = env { seBars = updateBars (seBars env) bar, seLastTimestamp = newTimestamp }
+      let newenv = env & seBars %~ (flip updateBars $ bar) & seLastTimestamp .~ newTimestamp
       curState <- gets robotState
       modify' (\s -> s { strategyEnvironment = newenv })
       handleEvents [NewBar bar])
@@ -232,7 +233,7 @@ backtestMain dataDownloadDelta defaultState initCallback callback = do
         order `executeAtPrice` barOpen bar
 
     executeAtPrice order price = do
-      ts <- seLastTimestamp <$> gets strategyEnvironment
+      ts <- view seLastTimestamp <$> gets strategyEnvironment
       modify' (\s -> s { tradesLog = mkTrade order price ts : tradesLog s })
       return $ OrderUpdate (orderId order) Executed
 

src/ATrade/Driver/Real.hs

@@ -31,6 +31,7 @@ import Control.Monad.Reader
 import Control.Concurrent hiding (writeChan, readChan, writeList2Chan, yield)
 import Control.Concurrent.BoundedChan as BC
 import Control.Exception.Safe
+import Control.Lens hiding (Context, (.=))
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Lazy as BL
 import qualified Data.List as L
@@ -46,7 +47,7 @@ import Data.Maybe
 import Data.Monoid
 import Database.Redis hiding (info, decode)
 import ATrade.Types
-import ATrade.RoboCom.Monad (StrategyMonad, StrategyAction(..), EventCallback, Event(..), runStrategyElement, StrategyEnvironment(..), Event(..), MonadRobot(..))
+import ATrade.RoboCom.Monad (StrategyMonad, StrategyAction(..), EventCallback, Event(..), runStrategyElement, StrategyEnvironment(..), seBars, seLastTimestamp, Event(..), MonadRobot(..))
 import ATrade.BarAggregator
 import ATrade.Driver.Real.BrokerClientThread
 import ATrade.Driver.Real.QuoteSourceThread
@@ -159,7 +160,7 @@ instance MonadRobot (App c s) c s where
     env <- lift $ readIORef envRef
     nowRef <- asks envLastTimestamp
     now <- lift $ readIORef nowRef
-    return $ env { seBars = bars agg, seLastTimestamp = now }
+    return $ env & seBars .~ bars agg & seLastTimestamp .~ now
 
 data BigConfig c = BigConfig {
   confTickers :: [Ticker],
@@ -244,11 +245,11 @@ robotMain dataDownloadDelta defaultState initCallback callback = do
     storeState params stateRef timersRef
 
   straEnv <- newIORef StrategyEnvironment {
-        seInstanceId = strategyInstanceId . strategyInstanceParams $ strategy,
-        seAccount = strategyAccount . strategyInstanceParams $ strategy,
-        seVolume = strategyVolume . strategyInstanceParams $ strategy,
-        seBars = M.empty,
-        seLastTimestamp = UTCTime (fromGregorian 1970 1 1) 0
+        _seInstanceId = strategyInstanceId . strategyInstanceParams $ strategy,
+        _seAccount = strategyAccount . strategyInstanceParams $ strategy,
+        _seVolume = strategyVolume . strategyInstanceParams $ strategy,
+        _seBars = M.empty,
+        _seLastTimestamp = UTCTime (fromGregorian 1970 1 1) 0
   }
   -- Event channel is for strategy events, like new tick arrival, or order execution notification
   eventChan <- BC.newBoundedChan 1000
@@ -515,7 +516,7 @@ barStrategyDriver ctx mbSourceTimeframe tickFilter strategy configRef stateRef t
             env <- getEnvironment
             let newTimestamp = case event of
                   NewTick tick -> timestamp tick
-                  _ -> seLastTimestamp env
+                  _ -> env ^. seLastTimestamp
             nowRef <- asks envLastTimestamp
             lift $ writeIORef nowRef newTimestamp
 

src/ATrade/RoboCom/Monad.hs

@@ -14,6 +14,11 @@ module ATrade.RoboCom.Monad (
   RActions,
   REnv,
   StrategyEnvironment(..),
+  seInstanceId,
+  seAccount,
+  seVolume,
+  seBars,
+  seLastTimestamp,
   StrategyElement,
   runStrategyElement,
   EventCallback,
@@ -31,12 +36,12 @@ import           ATrade.Types
 
 import           Ether
 
+import           Control.Lens
 import           Data.Aeson.Types
 import qualified Data.Text            as T
 import           Data.Time.Clock
 import           Text.Printf.TH
 
-
 class (Monad m) => MonadRobot m c s | m -> c, m -> s where
   submitOrder :: Order -> m ()
   cancelOrder :: OrderId -> m ()
@@ -84,12 +89,14 @@ data StrategyAction = ActionOrder Order
   | ActionIO Int (IO Value)
 
 data StrategyEnvironment = StrategyEnvironment {
-  seInstanceId    :: !T.Text, -- ^ Strategy instance identifier. Should be unique among all strategies (very desirable)
-  seAccount       :: !T.Text, -- ^ Account string to use for this strategy instance. Broker-dependent
-  seVolume        :: !Int, -- ^ Volume to use for this instance (in lots/contracts)
-  seBars          :: !Bars, -- ^ List of tickers which is used by this strategy
-  seLastTimestamp :: !UTCTime
+  _seInstanceId    :: !T.Text, -- ^ Strategy instance identifier. Should be unique among all strategies (very desirable)
+  _seAccount       :: !T.Text, -- ^ Account string to use for this strategy instance. Broker-dependent
+  _seVolume        :: !Int, -- ^ Volume to use for this instance (in lots/contracts)
+  _seBars          :: !Bars, -- ^ List of tickers which is used by this strategy
+  _seLastTimestamp :: !UTCTime
 } deriving (Eq)
+makeLenses ''StrategyEnvironment
+
 
 instance Show StrategyAction where
   show (ActionOrder order)     = "ActionOrder " ++ show order

src/ATrade/RoboCom/Positions.hs

@@ -73,6 +73,7 @@ import           ATrade.RoboCom.Monad
 import           ATrade.RoboCom.Types
 import           ATrade.Types
 
+import           Control.Lens
 import           Control.Monad
 import           Ether
 
@@ -186,7 +187,7 @@ dispatchPosition event pos = case posState pos of
   PositionCancelled -> handlePositionCancelled pos
   where
     handlePositionWaitingOpenSubmission pendingOrder = do
-      lastTs <- seLastTimestamp <$> getEnvironment
+      lastTs <- view seLastTimestamp <$> getEnvironment
       if orderDeadline (posSubmissionDeadline pos) lastTs
         then return $ pos { posState = PositionCancelled } -- TODO call TimeoutHandler if present
         else case event of
@@ -199,7 +200,7 @@ dispatchPosition event pos = case posState pos of
           _ -> return pos
 
     handlePositionWaitingOpen = do
-      lastTs <- seLastTimestamp <$> getEnvironment
+      lastTs <- view seLastTimestamp <$> getEnvironment
       case posCurrentOrder pos of
         Just order -> if orderDeadline (posExecutionDeadline pos) lastTs
           then do -- TODO call TimeoutHandler
@@ -238,7 +239,7 @@ dispatchPosition event pos = case posState pos of
           return pos
 
     handlePositionOpen = do
-      lastTs <- seLastTimestamp <$> getEnvironment
+      lastTs <- view seLastTimestamp <$> getEnvironment
       if
         | orderDeadline (posSubmissionDeadline pos) lastTs -> do
             appendToLog $ [st|PositionId: %? : Missed submission deadline: %?, remaining in PositionOpen state|] (posId pos) (posSubmissionDeadline pos)
@@ -261,7 +262,7 @@ dispatchPosition event pos = case posState pos of
           _ -> return pos
 
     handlePositionWaitingPendingCancellation = do
-      lastTs <- seLastTimestamp <$> getEnvironment
+      lastTs <- view seLastTimestamp <$> getEnvironment
       if not $ orderDeadline (posSubmissionDeadline pos) lastTs
         then case (event, posCurrentOrder pos, posNextState pos) of
             (OrderUpdate _ newstate, Just _, Just (PositionWaitingCloseSubmission nextOrder)) ->
@@ -280,7 +281,7 @@ dispatchPosition event pos = case posState pos of
           return pos { posState = PositionCancelled }
 
     handlePositionWaitingCloseSubmission pendingOrder = do
-      lastTs <- seLastTimestamp <$> getEnvironment
+      lastTs <- view seLastTimestamp <$> getEnvironment
       if orderDeadline (posSubmissionDeadline pos) lastTs
         then do
           case posCurrentOrder pos of
@@ -297,7 +298,7 @@ dispatchPosition event pos = case posState pos of
           _ -> return pos
 
     handlePositionWaitingClose = do
-      lastTs <- seLastTimestamp <$> getEnvironment
+      lastTs <- view seLastTimestamp <$> getEnvironment
       if orderDeadline (posExecutionDeadline pos) lastTs
         then do
           case posCurrentOrder pos of
@@ -335,7 +336,7 @@ dispatchPosition event pos = case posState pos of
 
 newPosition :: (StateHasPositions s, MonadRobot m c s) => Order -> T.Text -> TickerId -> Operation -> Int -> NominalDiffTime -> m Position
 newPosition order account tickerId operation quantity submissionDeadline = do
-  lastTs <- seLastTimestamp <$> getEnvironment
+  lastTs <- view seLastTimestamp <$> getEnvironment
   let position = Position {
     posId = [st|%?/%?/%?/%?/%?|] account tickerId operation quantity lastTs,
     posAccount = account,
@@ -359,7 +360,7 @@ newPosition order account tickerId operation quantity submissionDeadline = do
 
 reapDeadPositions :: (StateHasPositions s) => EventCallback c s
 reapDeadPositions _ = do
-  ts <- seLastTimestamp <$> getEnvironment
+  ts <- view seLastTimestamp <$> getEnvironment
   when (floor (utctDayTime ts) `mod` 300 == 0) $ modifyPositions (L.filter (not . posIsDead))
 
 defaultHandler :: (StateHasPositions s) => EventCallback c s
@@ -377,15 +378,15 @@ modifyPosition f oldpos = do
 
 getCurrentTicker :: (ParamsHasMainTicker c, MonadRobot m c s) => m [Bar]
 getCurrentTicker = do
-  bars <- seBars <$> getEnvironment
-  maybeBars <- flip M.lookup bars .  mainTicker <$> getConfig
+  mainTicker' <- mainTicker <$> getConfig
+  maybeBars <- view (seBars . at mainTicker') <$> getEnvironment
   case maybeBars of
     Just b -> return $ bsBars b
     _      -> return []
 
 getCurrentTickerSeries :: (ParamsHasMainTicker c, MonadRobot m c s) => m (Maybe BarSeries)
 getCurrentTickerSeries = do
-  bars <- seBars <$> getEnvironment
+  bars <- view seBars <$> getEnvironment
   flip M.lookup bars . mainTicker <$> getConfig
 
 getLastActivePosition :: (StateHasPositions s, MonadRobot m c s) => m (Maybe Position)
@@ -449,7 +450,7 @@ onActionCompletedEvent event f = case event of
 enterAtMarket :: (StateHasPositions s, ParamsHasMainTicker c, MonadRobot m c s) => T.Text -> Operation -> m Position
 enterAtMarket signalName operation = do
   env <- getEnvironment
-  enterAtMarketWithParams (seAccount env) (seVolume env) (SignalId (seInstanceId env) signalName "") operation
+  enterAtMarketWithParams (env ^. seAccount) (env ^. seVolume) (SignalId (env ^. seInstanceId) signalName "") operation
 
 enterAtMarketWithParams :: (StateHasPositions s, ParamsHasMainTicker c, MonadRobot m c s) => T.Text -> Int -> SignalId -> Operation -> m Position
 enterAtMarketWithParams account quantity signalId operation = do
@@ -469,12 +470,12 @@ enterAtMarketWithParams account quantity signalId operation = do
 enterAtLimit :: (StateHasPositions s, ParamsHasMainTicker c, MonadRobot m c s) => NominalDiffTime -> T.Text -> Price -> Operation -> m Position
 enterAtLimit timeToCancel signalName price operation = do
   env <- getEnvironment
-  enterAtLimitWithParams timeToCancel (seAccount env) (seVolume env) (SignalId (seInstanceId env) signalName "") price operation
+  enterAtLimitWithParams timeToCancel (env ^. seAccount) (env ^. seVolume) (SignalId (env ^. seInstanceId) signalName "") price operation
 
 enterAtLimitWithVolume :: (StateHasPositions s, ParamsHasMainTicker c, MonadRobot m c s) => NominalDiffTime -> T.Text -> Price -> Int -> Operation -> m Position
 enterAtLimitWithVolume timeToCancel signalName price vol operation = do
-  acc <- seAccount <$> getEnvironment
-  inst <- seInstanceId <$> getEnvironment
+  acc <- view seAccount <$> getEnvironment
+  inst <- view seInstanceId <$> getEnvironment
   enterAtLimitWithParams timeToCancel acc vol (SignalId inst signalName "") price operation
 
 enterAtLimitWithParams :: (StateHasPositions s, ParamsHasMainTicker c, MonadRobot m c s) => NominalDiffTime -> T.Text -> Int -> SignalId -> Price -> Operation -> m Position
@@ -484,20 +485,20 @@ enterAtLimitWithParams timeToCancel account quantity signalId price operation =
 
 enterAtLimitForTickerWithVolume :: (StateHasPositions s, MonadRobot m c s) => TickerId -> NominalDiffTime -> T.Text -> Price -> Int -> Operation -> m Position
 enterAtLimitForTickerWithVolume tickerId timeToCancel signalName price vol operation = do
-  acc <- seAccount <$> getEnvironment
-  inst <- seInstanceId <$> getEnvironment
+  acc <- view seAccount <$> getEnvironment
+  inst <- view seInstanceId <$> getEnvironment
   enterAtLimitForTickerWithParams tickerId timeToCancel acc vol (SignalId inst signalName "") price operation
 
 enterAtLimitForTicker :: (StateHasPositions s, MonadRobot m c s) => TickerId -> NominalDiffTime -> T.Text -> Price -> Operation -> m Position
 enterAtLimitForTicker tickerId timeToCancel signalName price operation = do
-  acc <- seAccount <$> getEnvironment
-  inst <- seInstanceId <$> getEnvironment
-  vol <- seVolume <$> getEnvironment
+  acc <- view seAccount <$> getEnvironment
+  inst <- view seInstanceId <$> getEnvironment
+  vol <- view seVolume <$> getEnvironment
   enterAtLimitForTickerWithParams tickerId timeToCancel acc vol (SignalId inst signalName "") price operation
 
 enterAtLimitForTickerWithParams :: (StateHasPositions s, MonadRobot m c s) => TickerId -> NominalDiffTime -> T.Text -> Int -> SignalId -> Price -> Operation -> m Position
 enterAtLimitForTickerWithParams tickerId timeToCancel account quantity signalId price operation = do
-  lastTs <- seLastTimestamp <$> getEnvironment
+  lastTs <- view seLastTimestamp <$> getEnvironment
   submitOrder order
   appendToLog $ [st|enterAtLimit: %?, deadline: %?|] tickerId (timeToCancel `addUTCTime` lastTs)
   newPosition order account tickerId operation quantity 20 >>=
@@ -532,8 +533,8 @@ enterShortAtLimitForTicker tickerId timeToCancel price signalName = enterAtLimit
 
 exitAtMarket :: (StateHasPositions s, MonadRobot m c s) => Position -> T.Text -> m Position
 exitAtMarket position signalName = do
-  inst <- seInstanceId <$> getEnvironment
-  lastTs <- seLastTimestamp <$> getEnvironment
+  inst <- view seInstanceId <$> getEnvironment
+  lastTs <- view seLastTimestamp <$> getEnvironment
   case posCurrentOrder position of
     Just order -> do
       cancelOrder (orderId order)
@@ -563,8 +564,8 @@ exitAtMarket position signalName = do
 
 exitAtLimit :: (StateHasPositions s, MonadRobot m c s) => NominalDiffTime -> Price -> Position -> T.Text -> m Position
 exitAtLimit timeToCancel price position signalName = do
-  lastTs <- seLastTimestamp <$> getEnvironment
-  inst <- seInstanceId <$> getEnvironment
+  lastTs <- view seLastTimestamp <$> getEnvironment
+  inst <- view seInstanceId <$> getEnvironment
   case posCurrentOrder position of
     Just order -> cancelOrder (orderId order)
     Nothing    -> doNothing