asakul
/
robocom-zero
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
Browse Source

Update to lts-17.14

stable
Denis Tereshkin 5 years ago
parent
9df3cd58dc
commit
fd7add7b4e
5 changed files with 28 additions and 25 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Unified View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 4
      robocom-zero.cabal
  2. 6
      src/ATrade/Exceptions.hs
  3. 4
      src/ATrade/RoboCom/Monad.hs
  4. 31
      src/ATrade/RoboCom/Positions.hs
  5. 6
      stack.yaml

4
robocom-zero.cabal
Unescape View File

@ -15,9 +15,10 @@ cabal-version: >=1.10
library library
hs-source-dirs: src hs-source-dirs: src
ghc-options: -Wall -Werror -fno-warn-orphans -Wno-type-defaults ghc-options: -Wall -fno-warn-orphans -Wno-type-defaults
exposed-modules: ATrade.RoboCom.Indicators exposed-modules: ATrade.RoboCom.Indicators
, ATrade.RoboCom.Monad , ATrade.RoboCom.Monad
, ATrade.RoboCom.Persistence
, ATrade.RoboCom.Positions , ATrade.RoboCom.Positions
, ATrade.RoboCom.Types , ATrade.RoboCom.Types
, ATrade.RoboCom.Utils , ATrade.RoboCom.Utils
@ -51,7 +52,6 @@ library
, binary-ieee754 , binary-ieee754
, zeromq4-haskell , zeromq4-haskell
, unordered-containers , unordered-containers
, ether
, th-printf , th-printf
, BoundedChan , BoundedChan
, monad-loops , monad-loops

6
src/ATrade/Exceptions.hs
Unescape View File

@ -8,7 +8,11 @@ import Control.Exception
import qualified Data.Text as T import qualified Data.Text as T
import GHC.Generics import GHC.Generics
data RoboComException = UnableToLoadConfig T.Text | UnableToLoadFeed T.Text data RoboComException = UnableToLoadConfig T.Text
| UnableToLoadFeed T.Text
| UnableToLoadState T.Text
| UnableToSaveState T.Text
| BadParams T.Text
deriving (Show, Generic) deriving (Show, Generic)
instance Exception RoboComException instance Exception RoboComException

4
src/ATrade/RoboCom/Monad.hs
Unescape View File

@ -19,7 +19,7 @@ module ATrade.RoboCom.Monad (
Event(..), Event(..),
MonadRobot(..), MonadRobot(..),
also, also,
st t
) where ) where
import ATrade.RoboCom.Types import ATrade.RoboCom.Types
@ -29,7 +29,7 @@ import Control.Lens
import Data.Aeson.Types import Data.Aeson.Types
import qualified Data.Text as T import qualified Data.Text as T
import Data.Time.Clock import Data.Time.Clock
import Text.Printf.TH import Language.Haskell.Printf
class (Monad m) => MonadRobot m c s | m -> c, m -> s where class (Monad m) => MonadRobot m c s | m -> c, m -> s where
submitOrder :: Order -> m () submitOrder :: Order -> m ()

31
src/ATrade/RoboCom/Positions.hs
Unescape View File

@ -81,6 +81,7 @@ import Data.Aeson
import qualified Data.List as L import qualified Data.List as L
import qualified Data.Map as M import qualified Data.Map as M
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import Data.Time.Clock import Data.Time.Clock
data PositionState = PositionWaitingOpenSubmission Order data PositionState = PositionWaitingOpenSubmission Order
@ -206,49 +207,49 @@ dispatchPosition event pos = case posState pos of
then then
if posBalance pos == 0 if posBalance pos == 0
then do then do
appendToLog $ [st|"In PositionWaitingOpen: execution timeout: %?/%?"|] (posExecutionDeadline pos) lastTs appendToLog $ TL.toStrict $ [t|"In PositionWaitingOpen: execution timeout: %?/%?"|] (posExecutionDeadline pos) lastTs
cancelOrder $ orderId order cancelOrder $ orderId order
return $ pos { posState = PositionWaitingPendingCancellation, posNextState = Just PositionCancelled } return $ pos { posState = PositionWaitingPendingCancellation, posNextState = Just PositionCancelled }
else do else do
appendToLog $ [st|Order executed (partially, %? / %?): %?|] (posBalance pos) (orderQuantity order) order appendToLog $ TL.toStrict $ [t|Order executed (partially, %? / %?): %?|] (posBalance pos) (orderQuantity order) order
return pos { posState = PositionOpen, posCurrentOrder = Nothing, posExecutionDeadline = Nothing, posEntryTime = Just lastTs} return pos { posState = PositionOpen, posCurrentOrder = Nothing, posExecutionDeadline = Nothing, posEntryTime = Just lastTs}
else case event of else case event of
OrderUpdate oid newstate -> OrderUpdate oid newstate ->
if oid == orderId order if oid == orderId order
then case newstate of then case newstate of
Cancelled -> do Cancelled -> do
appendToLog $ [st|Order cancelled in PositionWaitingOpen: balance %d, max %d|] (posBalance pos) (orderQuantity order) appendToLog $ TL.toStrict $ [t|Order cancelled in PositionWaitingOpen: balance %d, max %d|] (posBalance pos) (orderQuantity order)
if posBalance pos /= 0 if posBalance pos /= 0
then return pos { posState = PositionOpen, posCurrentOrder = Nothing, posExecutionDeadline = Nothing, posEntryTime = Just lastTs} then return pos { posState = PositionOpen, posCurrentOrder = Nothing, posExecutionDeadline = Nothing, posEntryTime = Just lastTs}
else return pos { posState = PositionCancelled } else return pos { posState = PositionCancelled }
Executed -> do Executed -> do
appendToLog $ [st|Order executed: %?|] order appendToLog $ TL.toStrict $ [t|Order executed: %?|] order
return pos { posState = PositionOpen, posCurrentOrder = Nothing, posExecutionDeadline = Nothing, posBalance = balanceForOrder order, posEntryTime = Just lastTs} return pos { posState = PositionOpen, posCurrentOrder = Nothing, posExecutionDeadline = Nothing, posBalance = balanceForOrder order, posEntryTime = Just lastTs}
Rejected -> do Rejected -> do
appendToLog $ [st|Order rejected: %?|] order appendToLog $ TL.toStrict $ [t|Order rejected: %?|] order
return pos { posState = PositionCancelled, posCurrentOrder = Nothing, posExecutionDeadline = Nothing, posBalance = 0, posEntryTime = Nothing } return pos { posState = PositionCancelled, posCurrentOrder = Nothing, posExecutionDeadline = Nothing, posBalance = 0, posEntryTime = Nothing }
_ -> do _ -> do
appendToLog $ [st|In PositionWaitingOpen: order state update: %?|] newstate appendToLog $ TL.toStrict $ [t|In PositionWaitingOpen: order state update: %?|] newstate
return pos return pos
else return pos -- Update for another position's order else return pos -- Update for another position's order
NewTrade trade -> do NewTrade trade -> do
appendToLog $ [st|Order new trade: %?/%?|] order trade appendToLog $ TL.toStrict $ [t|Order new trade: %?/%?|] order trade
return $ if tradeOrderId trade == orderId order return $ if tradeOrderId trade == orderId order
then pos { posBalance = if tradeOperation trade == Buy then posBalance pos + tradeQuantity trade else posBalance pos - tradeQuantity trade } then pos { posBalance = if tradeOperation trade == Buy then posBalance pos + tradeQuantity trade else posBalance pos - tradeQuantity trade }
else pos else pos
_ -> return pos _ -> return pos
Nothing -> do Nothing -> do
appendToLog $ [st|W: No current order in PositionWaitingOpen state: %?|] pos appendToLog $ TL.toStrict $ [t|W: No current order in PositionWaitingOpen state: %?|] pos
return pos return pos
handlePositionOpen = do handlePositionOpen = do
lastTs <- view seLastTimestamp <$> getEnvironment lastTs <- view seLastTimestamp <$> getEnvironment
if if
| orderDeadline (posSubmissionDeadline pos) lastTs -> do | orderDeadline (posSubmissionDeadline pos) lastTs -> do
appendToLog $ [st|PositionId: %? : Missed submission deadline: %?, remaining in PositionOpen state|] (posId pos) (posSubmissionDeadline pos) appendToLog $ TL.toStrict $ [t|PositionId: %? : Missed submission deadline: %?, remaining in PositionOpen state|] (posId pos) (posSubmissionDeadline pos)
return pos { posSubmissionDeadline = Nothing, posExecutionDeadline = Nothing } return pos { posSubmissionDeadline = Nothing, posExecutionDeadline = Nothing }
| orderDeadline (posExecutionDeadline pos) lastTs -> do | orderDeadline (posExecutionDeadline pos) lastTs -> do
appendToLog $ [st|PositionId: %? : Missed execution deadline: %?, remaining in PositionOpen state|] (posId pos) (posExecutionDeadline pos) appendToLog $ TL.toStrict $ [t|PositionId: %? : Missed execution deadline: %?, remaining in PositionOpen state|] (posId pos) (posExecutionDeadline pos)
return pos { posExecutionDeadline = Nothing } return pos { posExecutionDeadline = Nothing }
| otherwise -> case event of | otherwise -> case event of
NewTick tick -> if NewTick tick -> if
@ -307,7 +308,7 @@ dispatchPosition event pos = case posState pos of
case posCurrentOrder pos of case posCurrentOrder pos of
Just order -> cancelOrder (orderId order) Just order -> cancelOrder (orderId order)
_ -> doNothing _ -> doNothing
appendToLog $ [st|Was unable to close position, remaining balance: %?|] (posBalance pos) appendToLog $ TL.toStrict $ [t|Was unable to close position, remaining balance: %?|] (posBalance pos)
return $ pos { posState = PositionOpen, posSubmissionDeadline = Nothing, posExecutionDeadline = Nothing } -- TODO call TimeoutHandler if present return $ pos { posState = PositionOpen, posSubmissionDeadline = Nothing, posExecutionDeadline = Nothing } -- TODO call TimeoutHandler if present
else case (event, posCurrentOrder pos) of else case (event, posCurrentOrder pos) of
(OrderUpdate oid newstate, Just order) -> (OrderUpdate oid newstate, Just order) ->
@ -347,7 +348,7 @@ newPosition :: (StateHasPositions s, MonadRobot m c s) => Order -> T.Text -> Tic
newPosition order account tickerId operation quantity submissionDeadline = do newPosition order account tickerId operation quantity submissionDeadline = do
lastTs <- view seLastTimestamp <$> getEnvironment lastTs <- view seLastTimestamp <$> getEnvironment
let position = Position { let position = Position {
posId = [st|%?/%?/%?/%?/%?|] account tickerId operation quantity lastTs, posId = TL.toStrict $ [t|%?/%?/%?/%?/%?|] account tickerId operation quantity lastTs,
posAccount = account, posAccount = account,
posTicker = tickerId, posTicker = tickerId,
posBalance = 0, posBalance = 0,
@ -364,7 +365,7 @@ newPosition order account tickerId operation quantity submissionDeadline = do
} }
modifyPositions (\p -> position : p) modifyPositions (\p -> position : p)
positions <- getPositions <$> getState positions <- getPositions <$> getState
appendToLog $ [st|All positions: %?|] positions appendToLog $ TL.toStrict $ [t|All positions: %?|] positions
return position return position
reapDeadPositions :: (StateHasPositions s) => EventCallback c s reapDeadPositions :: (StateHasPositions s) => EventCallback c s
@ -509,7 +510,7 @@ enterAtLimitForTickerWithParams :: (StateHasPositions s, MonadRobot m c s) => Ti
enterAtLimitForTickerWithParams tickerId timeToCancel account quantity signalId price operation = do enterAtLimitForTickerWithParams tickerId timeToCancel account quantity signalId price operation = do
lastTs <- view seLastTimestamp <$> getEnvironment lastTs <- view seLastTimestamp <$> getEnvironment
submitOrder order submitOrder order
appendToLog $ [st|enterAtLimit: %?, deadline: %?|] tickerId (timeToCancel `addUTCTime` lastTs) appendToLog $ TL.toStrict $ [t|enterAtLimit: %?, deadline: %?|] tickerId (timeToCancel `addUTCTime` lastTs)
newPosition order account tickerId operation quantity 20 >>= newPosition order account tickerId operation quantity 20 >>=
modifyPosition (\p -> p { posExecutionDeadline = Just $ timeToCancel `addUTCTime` lastTs }) modifyPosition (\p -> p { posExecutionDeadline = Just $ timeToCancel `addUTCTime` lastTs })
where where
@ -579,7 +580,7 @@ exitAtLimit timeToCancel price position operationSignalName = do
Just order -> cancelOrder (orderId order) Just order -> cancelOrder (orderId order)
Nothing -> doNothing Nothing -> doNothing
submitOrder (closeOrder inst) submitOrder (closeOrder inst)
appendToLog $ [st|exitAtLimit: %?, deadline: %?|] (posTicker position) (timeToCancel `addUTCTime` lastTs) appendToLog $ TL.toStrict $ [t|exitAtLimit: %?, deadline: %?|] (posTicker position) (timeToCancel `addUTCTime` lastTs)
modifyPosition (\pos -> modifyPosition (\pos ->
pos { posCurrentOrder = Nothing, pos { posCurrentOrder = Nothing,
posState = PositionWaitingCloseSubmission (closeOrder inst), posState = PositionWaitingCloseSubmission (closeOrder inst),

6
stack.yaml
Unescape View File

@ -18,7 +18,7 @@
# #
# resolver: ./custom-snapshot.yaml # resolver: ./custom-snapshot.yaml
# resolver: https://example.com/snapshots/2018-01-01.yaml # resolver: https://example.com/snapshots/2018-01-01.yaml
resolver: lts-12.9 resolver: lts-17.14
# User packages to be built. # User packages to be built.
# Various formats can be used as shown in the example below. # Various formats can be used as shown in the example below.
@ -46,10 +46,8 @@ extra-deps:
- list-extras-0.4.1.4 - list-extras-0.4.1.4
- snowball-1.0.0.1 - snowball-1.0.0.1
- binary-ieee754-0.1.0.0 - binary-ieee754-0.1.0.0
- th-printf-0.5.1 - th-printf-0.7
- normaldistribution-1.1.0.3 - normaldistribution-1.1.0.3
- text-format-0.3.2
- ether-0.5.1.0
# Override default flag values for local packages and extra-deps # Override default flag values for local packages and extra-deps
# flags: {} # flags: {}

Write Preview
Loading…
Cancel
Save