diff --git a/robocom-zero.cabal b/robocom-zero.cabal index 94acfd3..749bc5c 100644 --- a/robocom-zero.cabal +++ b/robocom-zero.cabal @@ -66,6 +66,7 @@ library , hedis , gitrev , data-default + , template-haskell default-language: Haskell2010 other-modules: ATrade.Exceptions diff --git a/src/ATrade/Driver/Backtest.hs b/src/ATrade/Driver/Backtest.hs index e4c94c5..46a8350 100644 --- a/src/ATrade/Driver/Backtest.hs +++ b/src/ATrade/Driver/Backtest.hs @@ -44,6 +44,7 @@ import qualified Data.Sequence as Seq import Data.STRef (newSTRef, readSTRef, writeSTRef) import qualified Data.Text as T import Data.Text.IO (putStrLn) +import qualified Data.Text.Lazy as TL import Data.Time.Calendar (fromGregorian) import Data.Time.Clock (DiffTime, UTCTime (..)) import Data.Vector ((!), (!?), (//)) @@ -314,7 +315,7 @@ instance MonadRobot (BacktestingMonad c s) c s where xs -> do mapM_ (\o -> pendingEvents %= (\s -> s |> (OrderUpdate (orderId o) Cancelled))) xs pendingOrders .= otherOrders - appendToLog txt = logs %= ((:) txt) + appendToLog txt = logs %= ((:) (TL.toStrict txt)) setupTimer time = pendingTimers %= ((:) time) enqueueIOAction _actionId _action = error "Backtesting io actions is not supported" getConfig = use robotParams diff --git a/src/ATrade/Driver/Real.hs b/src/ATrade/Driver/Real.hs index 7924988..8fcc815 100644 --- a/src/ATrade/Driver/Real.hs +++ b/src/ATrade/Driver/Real.hs @@ -47,6 +47,7 @@ import qualified Data.Map as M import Data.Maybe import qualified Data.Text as T import Data.Text.Encoding +import qualified Data.Text.Lazy as TL import Data.Time.Calendar import Data.Time.Clock import Data.Time.Clock.POSIX @@ -59,7 +60,6 @@ import System.Log.Formatter import System.Log.Handler (setFormatter) import System.Log.Handler.Simple import System.Log.Logger -import System.Random import System.Signal import System.ZMQ4 hiding (Event (..)) @@ -141,7 +141,7 @@ instance MonadRobot (App historySource c s) c s where bc <- asks envBrokerChan lift $ BC.writeChan bc $ BrokerCancelOrder oId - appendToLog = lift . debugM "Strategy" . T.unpack + appendToLog = lift . debugM "Strategy" . T.unpack . TL.toStrict setupTimer t = do timers <- asks envTimers lift $ atomicModifyIORef' timers (\s -> (t : s, ())) diff --git a/src/ATrade/Driver/Types.hs b/src/ATrade/Driver/Types.hs index 2736a81..04e2a53 100644 --- a/src/ATrade/Driver/Types.hs +++ b/src/ATrade/Driver/Types.hs @@ -6,11 +6,9 @@ module ATrade.Driver.Types InitializationCallback ) where -import ATrade.RoboCom.Monad import ATrade.RoboCom.Types import qualified Data.Text as T -import Data.Time.Clock -- | Strategy instance params store few params which are common for all strategies data StrategyInstanceParams = StrategyInstanceParams { diff --git a/src/ATrade/RoboCom/Monad.hs b/src/ATrade/RoboCom/Monad.hs index 69a4769..b9cd3be 100644 --- a/src/ATrade/RoboCom/Monad.hs +++ b/src/ATrade/RoboCom/Monad.hs @@ -19,7 +19,8 @@ module ATrade.RoboCom.Monad ( Event(..), MonadRobot(..), also, - t + t, + st ) where import ATrade.RoboCom.Types @@ -27,14 +28,16 @@ import ATrade.Types import Control.Lens import Data.Aeson.Types -import qualified Data.Text as T +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL import Data.Time.Clock import Language.Haskell.Printf +import Language.Haskell.TH.Quote (QuasiQuoter) class (Monad m) => MonadRobot m c s | m -> c, m -> s where submitOrder :: Order -> m () cancelOrder :: OrderId -> m () - appendToLog :: T.Text -> m () + appendToLog :: TL.Text -> m () setupTimer :: UTCTime -> m () enqueueIOAction :: Int -> IO Value -> m () getConfig :: m c @@ -46,6 +49,9 @@ class (Monad m) => MonadRobot m c s | m -> c, m -> s where setState (f oldState) getEnvironment :: m StrategyEnvironment +st :: QuasiQuoter +st = t + type EventCallback c s = forall m . MonadRobot m c s => Event -> m () data Event = NewBar Bar diff --git a/src/ATrade/RoboCom/Positions.hs b/src/ATrade/RoboCom/Positions.hs index a8afc27..7ddb711 100644 --- a/src/ATrade/RoboCom/Positions.hs +++ b/src/ATrade/RoboCom/Positions.hs @@ -207,49 +207,49 @@ dispatchPosition event pos = case posState pos of then if posBalance pos == 0 then do - appendToLog $ TL.toStrict $ [t|"In PositionWaitingOpen: execution timeout: %?/%?"|] (posExecutionDeadline pos) lastTs + appendToLog $ [t|"In PositionWaitingOpen: execution timeout: %?/%?"|] (posExecutionDeadline pos) lastTs cancelOrder $ orderId order return $ pos { posState = PositionWaitingPendingCancellation, posNextState = Just PositionCancelled } else do - appendToLog $ TL.toStrict $ [t|Order executed (partially, %? / %?): %?|] (posBalance pos) (orderQuantity order) order + appendToLog $ [t|Order executed (partially, %? / %?): %?|] (posBalance pos) (orderQuantity order) order return pos { posState = PositionOpen, posCurrentOrder = Nothing, posExecutionDeadline = Nothing, posEntryTime = Just lastTs} else case event of OrderUpdate oid newstate -> if oid == orderId order then case newstate of Cancelled -> do - appendToLog $ TL.toStrict $ [t|Order cancelled in PositionWaitingOpen: balance %d, max %d|] (posBalance pos) (orderQuantity order) + appendToLog $ [t|Order cancelled in PositionWaitingOpen: balance %d, max %d|] (posBalance pos) (orderQuantity order) if posBalance pos /= 0 then return pos { posState = PositionOpen, posCurrentOrder = Nothing, posExecutionDeadline = Nothing, posEntryTime = Just lastTs} else return pos { posState = PositionCancelled } Executed -> do - appendToLog $ TL.toStrict $ [t|Order executed: %?|] order + appendToLog $ [t|Order executed: %?|] order return pos { posState = PositionOpen, posCurrentOrder = Nothing, posExecutionDeadline = Nothing, posBalance = balanceForOrder order, posEntryTime = Just lastTs} Rejected -> do - appendToLog $ TL.toStrict $ [t|Order rejected: %?|] order + appendToLog $ [t|Order rejected: %?|] order return pos { posState = PositionCancelled, posCurrentOrder = Nothing, posExecutionDeadline = Nothing, posBalance = 0, posEntryTime = Nothing } _ -> do - appendToLog $ TL.toStrict $ [t|In PositionWaitingOpen: order state update: %?|] newstate + appendToLog $ [t|In PositionWaitingOpen: order state update: %?|] newstate return pos else return pos -- Update for another position's order NewTrade trade -> do - appendToLog $ TL.toStrict $ [t|Order new trade: %?/%?|] order trade + appendToLog $ [t|Order new trade: %?/%?|] order trade return $ if tradeOrderId trade == orderId order then pos { posBalance = if tradeOperation trade == Buy then posBalance pos + tradeQuantity trade else posBalance pos - tradeQuantity trade } else pos _ -> return pos Nothing -> do - appendToLog $ TL.toStrict $ [t|W: No current order in PositionWaitingOpen state: %?|] pos + appendToLog $ [t|W: No current order in PositionWaitingOpen state: %?|] pos return pos handlePositionOpen = do lastTs <- view seLastTimestamp <$> getEnvironment if | orderDeadline (posSubmissionDeadline pos) lastTs -> do - appendToLog $ TL.toStrict $ [t|PositionId: %? : Missed submission deadline: %?, remaining in PositionOpen state|] (posId pos) (posSubmissionDeadline pos) + appendToLog $ [t|PositionId: %? : Missed submission deadline: %?, remaining in PositionOpen state|] (posId pos) (posSubmissionDeadline pos) return pos { posSubmissionDeadline = Nothing, posExecutionDeadline = Nothing } | orderDeadline (posExecutionDeadline pos) lastTs -> do - appendToLog $ TL.toStrict $ [t|PositionId: %? : Missed execution deadline: %?, remaining in PositionOpen state|] (posId pos) (posExecutionDeadline pos) + appendToLog $ [t|PositionId: %? : Missed execution deadline: %?, remaining in PositionOpen state|] (posId pos) (posExecutionDeadline pos) return pos { posExecutionDeadline = Nothing } | otherwise -> case event of NewTick tick -> if @@ -308,7 +308,7 @@ dispatchPosition event pos = case posState pos of case posCurrentOrder pos of Just order -> cancelOrder (orderId order) _ -> doNothing - appendToLog $ TL.toStrict $ [t|Was unable to close position, remaining balance: %?|] (posBalance pos) + appendToLog $ [t|Was unable to close position, remaining balance: %?|] (posBalance pos) return $ pos { posState = PositionOpen, posSubmissionDeadline = Nothing, posExecutionDeadline = Nothing } -- TODO call TimeoutHandler if present else case (event, posCurrentOrder pos) of (OrderUpdate oid newstate, Just order) -> @@ -365,7 +365,7 @@ newPosition order account tickerId operation quantity submissionDeadline = do } modifyPositions (\p -> position : p) positions <- getPositions <$> getState - appendToLog $ TL.toStrict $ [t|All positions: %?|] positions + appendToLog $ [t|All positions: %?|] positions return position reapDeadPositions :: (StateHasPositions s) => EventCallback c s @@ -510,7 +510,7 @@ enterAtLimitForTickerWithParams :: (StateHasPositions s, MonadRobot m c s) => Ti enterAtLimitForTickerWithParams tickerId timeToCancel account quantity signalId price operation = do lastTs <- view seLastTimestamp <$> getEnvironment submitOrder order - appendToLog $ TL.toStrict $ [t|enterAtLimit: %?, deadline: %?|] tickerId (timeToCancel `addUTCTime` lastTs) + appendToLog $ [t|enterAtLimit: %?, deadline: %?|] tickerId (timeToCancel `addUTCTime` lastTs) newPosition order account tickerId operation quantity 20 >>= modifyPosition (\p -> p { posExecutionDeadline = Just $ timeToCancel `addUTCTime` lastTs }) where @@ -580,7 +580,7 @@ exitAtLimit timeToCancel price position operationSignalName = do Just order -> cancelOrder (orderId order) Nothing -> doNothing submitOrder (closeOrder inst) - appendToLog $ TL.toStrict $ [t|exitAtLimit: %?, deadline: %?|] (posTicker position) (timeToCancel `addUTCTime` lastTs) + appendToLog $ [t|exitAtLimit: %?, deadline: %?|] (posTicker position) (timeToCancel `addUTCTime` lastTs) modifyPosition (\pos -> pos { posCurrentOrder = Nothing, posState = PositionWaitingCloseSubmission (closeOrder inst),