From 8e34ac61d5320d878a05d1344ca651ac2ea6ed9e Mon Sep 17 00:00:00 2001 From: Denis Tereshkin Date: Mon, 13 Apr 2020 13:05:03 +0700 Subject: [PATCH] More cleanup & warning elimination --- robocom-zero.cabal | 2 +- src/ATrade/Backtest/Execution.hs | 102 ------------- src/ATrade/BarAggregator.hs | 15 +- src/ATrade/Driver/Backtest.hs | 32 ++-- src/ATrade/Driver/Real.hs | 12 +- src/ATrade/Driver/Real/BrokerClientThread.hs | 1 - src/ATrade/Driver/Real/QuoteSourceThread.hs | 4 - src/ATrade/Forums/Smartlab.hs | 153 ------------------- src/ATrade/Quotes/Finam.hs | 4 +- src/ATrade/Quotes/HAP.hs | 8 +- src/ATrade/Quotes/QHP.hs | 1 - src/ATrade/RoboCom/Indicators.hs | 4 +- src/ATrade/RoboCom/Positions.hs | 42 ++--- src/ATrade/RoboCom/Types.hs | 3 - src/ATrade/RoboCom/Utils.hs | 5 +- 15 files changed, 53 insertions(+), 335 deletions(-) delete mode 100644 src/ATrade/Backtest/Execution.hs delete mode 100644 src/ATrade/Forums/Smartlab.hs diff --git a/robocom-zero.cabal b/robocom-zero.cabal index 38b9a43..1a21917 100644 --- a/robocom-zero.cabal +++ b/robocom-zero.cabal @@ -15,7 +15,7 @@ cabal-version: >=1.10 library hs-source-dirs: src - ghc-options: -Wall -fno-warn-orphans -Wno-type-defaults + ghc-options: -Wall -Werror -fno-warn-orphans -Wno-type-defaults exposed-modules: ATrade.RoboCom.Indicators , ATrade.RoboCom.Monad , ATrade.RoboCom.Positions diff --git a/src/ATrade/Backtest/Execution.hs b/src/ATrade/Backtest/Execution.hs deleted file mode 100644 index 643c180..0000000 --- a/src/ATrade/Backtest/Execution.hs +++ /dev/null @@ -1,102 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module ATrade.Backtest.Execution ( - mkExecutionAgent, - ExecutionAgent(..), - executePending, - executeStep -) where - -import qualified Data.Text as T -import qualified Data.Map as M -import qualified Data.List as L -import ATrade.Types -import ATrade.Strategy.Types -import ATrade.Strategy -import Control.Monad.State -import Control.Monad.Trans.Writer -import Data.Decimal -import Data.Time.Clock -import Data.Time.Calendar - -data Position = Position { - ticker :: T.Text, - balance :: Int } - -data ExecutionAgent = ExecutionAgent { - pendingOrders :: [Order], - cash :: Decimal, - currentTime :: UTCTime, - orderIdCounter :: Integer -} - -mkExecutionAgent startCash = ExecutionAgent { pendingOrders = [], - cash = startCash, - currentTime = UTCTime (fromGregorian 1970 1 1) 0, - orderIdCounter = 1 } - -executeAtPrice :: Order -> Decimal -> WriterT [Event] (State ExecutionAgent) () -executeAtPrice order price = do - when (orderState order == Unsubmitted) $ tell [OrderSubmitted order] - tell [OrderUpdate (orderId order) Executed] - timestamp <- gets currentTime - tell [NewTrade (mkTradeForOrder timestamp order price)] - - case orderOperation order of - Buy -> modify' (\agent -> agent { cash = cash agent - price * realFracToDecimal 10 (toRational $ orderQuantity order) }) - Sell -> modify' (\agent -> agent { cash = cash agent + price * realFracToDecimal 10 (toRational $ orderQuantity order) }) - -mkTradeForOrder timestamp order price = Trade { tradeOrderId = orderId order, - tradePrice = price, - tradeQuantity = orderQuantity order, - tradeVolume = price * realFracToDecimal 10 (toRational $ orderQuantity order), - tradeVolumeCurrency = "TEST_CURRENCY", - tradeOperation = orderOperation order, - tradeAccount = orderAccountId order, - tradeSecurity = orderSecurity order, - tradeTimestamp = timestamp, - tradeSignalId = orderSignalId order } - - -executePending :: Bars -> WriterT [Event] (State ExecutionAgent) () -executePending bars = do - orders <- gets pendingOrders - let (executedOrders, leftover) = L.partition shouldExecute orders - - mapM_ executeAtOrdersPrice executedOrders - modify' (\s -> s { pendingOrders = leftover } ) - where - executeAtOrdersPrice order = case orderPrice order of - Limit price -> executeAtPrice order price - _ -> return () -- TODO handle stops - - shouldExecute order = case M.lookup (orderSecurity order) bars of - Just (DataSeries ((ts, bar) : _)) -> case orderPrice order of - Limit price -> crosses bar price - _ -> False - Nothing -> False - - crosses bar price = (barClose bar > price && barOpen bar < price) || (barClose bar < price && barOpen bar > price) - -executeStep :: Bars -> [Order] -> WriterT [Event] (State ExecutionAgent) () -executeStep bars orders = do - -- Assign consecutive IDs - orders' <- mapM (\o -> do - id <- gets orderIdCounter - modify(\s -> s { orderIdCounter = id + 1 }) - return o { orderId = id }) orders - - let (executableNow, pending) = L.partition isExecutableNow orders' - mapM_ (executeOrderAtLastPrice bars) executableNow - modify' (\s -> s { pendingOrders = pending ++ pendingOrders s }) - - where - isExecutableNow order = case M.lookup (orderSecurity order) bars of - Just (DataSeries (x:xs)) -> case orderPrice order of - Limit price -> (orderOperation order == Buy && price >= (barClose . snd) x) || (orderOperation order == Sell && price <= (barClose . snd) x) - Market -> True - _ -> False - - executeOrderAtLastPrice bars order = case M.lookup (orderSecurity order) bars of - Just (DataSeries ((ts, bar) : _)) -> executeAtPrice order (barClose bar) - _ -> return () diff --git a/src/ATrade/BarAggregator.hs b/src/ATrade/BarAggregator.hs index 5523473..f8b73bc 100644 --- a/src/ATrade/BarAggregator.hs +++ b/src/ATrade/BarAggregator.hs @@ -32,7 +32,6 @@ import Control.Lens import Control.Monad.State import qualified Data.Map.Strict as M import Data.Time.Clock -import Debug.Trace -- | Bar aggregator state data BarAggregator = BarAggregator { @@ -110,7 +109,7 @@ handleTick tick = runState $ do else return Nothing where - isInTimeInterval tick (a, b) = (utctDayTime . timestamp) tick >= a && (utctDayTime . timestamp) tick <= b + isInTimeInterval tick' (a, b) = (utctDayTime . timestamp) tick' >= a && (utctDayTime . timestamp) tick' <= b barFromTick !newtick = Bar { barSecurity = security newtick, barTimestamp = timestamp newtick, barOpen = value newtick, @@ -134,18 +133,6 @@ handleTick tick = runState $ do where newTimestamp = timestamp newtick - emptyBarFrom !bar newtick = newBar - where - newTimestamp = timestamp newtick - newBar = Bar { - barSecurity = barSecurity bar, - barTimestamp = newTimestamp, - barOpen = barClose bar, - barHigh = barClose bar, - barLow = barClose bar, - barClose = barClose bar, - barVolume = 0 } - updateTime :: Tick -> BarAggregator -> (Maybe Bar, BarAggregator) updateTime tick = runState $ do lLastTicks %= M.insert (security tick, datatype tick) tick diff --git a/src/ATrade/Driver/Backtest.hs b/src/ATrade/Driver/Backtest.hs index c20de38..eb8d71d 100644 --- a/src/ATrade/Driver/Backtest.hs +++ b/src/ATrade/Driver/Backtest.hs @@ -14,15 +14,13 @@ module ATrade.Driver.Backtest ( ) where import ATrade.Driver.Types (InitializationCallback, - Strategy (..), StrategyInstanceParams (..)) import ATrade.Exceptions import ATrade.Quotes.Finam as QF import ATrade.RoboCom.Monad (Event (..), EventCallback, MonadRobot (..), StrategyEnvironment (..), - appendToLog, seBars, seLastTimestamp, - st) + appendToLog, seBars, seLastTimestamp) import ATrade.RoboCom.Positions import ATrade.RoboCom.Types (BarSeries (..), Ticker (..), Timeframe (..)) @@ -30,16 +28,15 @@ import ATrade.Types import Conduit (awaitForever, runConduit, yield, (.|)) import Control.Exception.Safe -import Control.Lens +import Control.Lens hiding (ix) import Control.Monad.ST (runST) import Control.Monad.State -import Data.Aeson (FromJSON (..), Result (..), - Value (..), decode) +import Data.Aeson (FromJSON (..), Value (..), decode) import Data.Aeson.Types (parseMaybe) import Data.ByteString.Lazy (readFile, toStrict) import Data.Default import Data.HashMap.Strict (lookup) -import Data.List (concat, filter, find, partition) +import Data.List (partition) import Data.List.Split (splitOn) import qualified Data.Map.Strict as M import Data.Semigroup ((<>)) @@ -95,7 +92,7 @@ feedArgParser = eitherReader (\s -> case splitOn ":" s of _ -> Left $ "Unable to parse feed id: " ++ s) backtestMain :: (FromJSON c, StateHasPositions s) => DiffTime -> s -> Maybe (InitializationCallback c) -> EventCallback c s -> IO () -backtestMain dataDownloadDelta defaultState initCallback callback = do +backtestMain _dataDownloadDelta defaultState initCallback callback = do params <- execParser opts (tickerList, config) <- loadStrategyConfig params @@ -116,7 +113,7 @@ backtestMain dataDownloadDelta defaultState initCallback callback = do feeds <- loadFeeds (paramsFeeds params) - runBacktestDriver feeds config tickerList + runBacktestDriver feeds updatedConfig tickerList where opts = info (helper <*> paramsParser) ( fullDesc <> header "ATrade strategy backtesting framework" ) @@ -141,14 +138,11 @@ backtestMain dataDownloadDelta defaultState initCallback callback = do Object o -> do mbTickers <- "tickers" `lookup` o mbParams <- "params" `lookup` o - tickers <- parseMaybe parseJSON mbTickers + tickers' <- parseMaybe parseJSON mbTickers params <- parseMaybe parseJSON mbParams - return (tickers, params) + return (tickers', params) _ -> Nothing - resultToMaybe (Error _) = Nothing - resultToMaybe (Success a) = Just a - barStreamFromFeeds feeds = case nextBar feeds of Just (bar, feeds') -> yield bar >> barStreamFromFeeds feeds' _ -> return () @@ -166,7 +160,6 @@ backtestMain dataDownloadDelta defaultState initCallback callback = do minIx <- newSTRef Nothing forM_ [0..(V.length feeds-1)] (\ix -> do let feed = feeds ! ix - curIx <- readSTRef minIx curTs <- readSTRef minTs case feed of x:_ -> case curTs of @@ -292,13 +285,14 @@ backtestMain dataDownloadDelta defaultState initCallback callback = do enqueueEvent event = pendingEvents %= ((:) event) -instance (Default c, Default s) => Default (BacktestState s c) +instance (Default c, Default s) => Default (BacktestState c s) where def = defaultBacktestState def def [] -defaultBacktestState s c tickerList = BacktestState 0 s c (StrategyEnvironment "" "" 1 tickers (UTCTime (fromGregorian 1970 1 1) 0)) [] [] [] 1 [] [] +defaultBacktestState :: s -> c -> [Ticker] -> BacktestState c s +defaultBacktestState s c tickerList = BacktestState 0 s c (StrategyEnvironment "" "" 1 tickers' (UTCTime (fromGregorian 1970 1 1) 0)) [] [] [] 1 [] [] where - tickers = M.fromList $ map (\x -> (code x, BarSeries (code x) (Timeframe (timeframeSeconds x)) [])) tickerList + tickers' = M.fromList $ map (\x -> (code x, BarSeries (code x) (Timeframe (timeframeSeconds x)) [])) tickerList newtype BacktestingMonad s c a = BacktestingMonad { unBacktestingMonad :: State (BacktestState s c) a } deriving (Functor, Applicative, Monad, MonadState (BacktestState s c)) @@ -324,7 +318,7 @@ instance MonadRobot (BacktestingMonad c s) c s where pendingOrders .= otherOrders appendToLog txt = logs %= ((:) txt) setupTimer time = pendingTimers %= ((:) time) - enqueueIOAction actionId action = error "Backtesting io actions is not supported" + enqueueIOAction _actionId _action = error "Backtesting io actions is not supported" getConfig = use robotParams getState = use robotState setState s = robotState .= s diff --git a/src/ATrade/Driver/Real.hs b/src/ATrade/Driver/Real.hs index 77b087d..bb77742 100644 --- a/src/ATrade/Driver/Real.hs +++ b/src/ATrade/Driver/Real.hs @@ -44,7 +44,6 @@ import Data.Time.Calendar import Data.Time.Clock import Data.Time.Clock.POSIX import Data.Maybe -import Data.Monoid import Database.Redis hiding (info, decode) import ATrade.Types import ATrade.RoboCom.Monad (EventCallback, Event(..), StrategyEnvironment(..), seBars, seLastTimestamp, Event(..), MonadRobot(..)) @@ -141,10 +140,10 @@ instance MonadRobot (App c s) c s where timers <- asks envTimers lift $ atomicModifyIORef' timers (\s -> (t : s, ())) - enqueueIOAction actionId action = do + enqueueIOAction actionId action' = do eventChan <- asks envEventChan lift $ void $ forkIO $ do - v <- action + v <- action' BC.writeChan eventChan $ ActionCompleted actionId v getConfig = asks envConfigRef >>= lift . readIORef @@ -282,7 +281,7 @@ robotMain dataDownloadDelta defaultState initCallback callback = do envAggregator = agg, envLastTimestamp = now } - runReaderT (barStrategyDriver ctx (sourceBarTimeframe params) tickFilter strategy configRef stateRef timersRef shutdownMv) env `finally` killThread stateSavingThread) + runReaderT (barStrategyDriver ctx (sourceBarTimeframe params) tickFilter strategy shutdownMv) env `finally` killThread stateSavingThread) where tickFilter :: Tick -> Bool tickFilter tick = @@ -476,8 +475,8 @@ mkBarStrategy instanceParams dd params initialState cb = BarStrategy { -- | Main function which handles incoming events (ticks/orders), passes them to strategy callback -- and executes returned strategy actions -barStrategyDriver :: Context -> Maybe Int -> (Tick -> Bool) -> Strategy c s -> IORef c -> IORef s -> IORef [UTCTime] -> MVar () -> App c s () -barStrategyDriver ctx mbSourceTimeframe tickFilter strategy configRef stateRef timersRef shutdownVar = do +barStrategyDriver :: Context -> Maybe Int -> (Tick -> Bool) -> Strategy c s -> MVar () -> App c s () +barStrategyDriver ctx mbSourceTimeframe tickFilter strategy shutdownVar = do eventChan <- asks envEventChan brokerChan <- asks envBrokerChan agg <- asks envAggregator @@ -522,6 +521,7 @@ barStrategyDriver ctx mbSourceTimeframe tickFilter strategy configRef stateRef t newTimers <- catMaybes <$> (mapM (checkTimer eventChan newTimestamp) $ strategyTimers strategy') (eventCallback strategy) event + timersRef <- asks envTimers lift $ writeIORef timersRef newTimers readAndHandleEvents agg strategy' diff --git a/src/ATrade/Driver/Real/BrokerClientThread.hs b/src/ATrade/Driver/Real/BrokerClientThread.hs index ee994da..ba0ce49 100644 --- a/src/ATrade/Driver/Real/BrokerClientThread.hs +++ b/src/ATrade/Driver/Real/BrokerClientThread.hs @@ -9,7 +9,6 @@ import ATrade.Broker.Client import ATrade.Broker.Protocol import ATrade.RoboCom.Monad hiding (cancelOrder, submitOrder) -import ATrade.RoboCom.Types import ATrade.Types import Control.Concurrent hiding (readChan, writeChan, diff --git a/src/ATrade/Driver/Real/QuoteSourceThread.hs b/src/ATrade/Driver/Real/QuoteSourceThread.hs index 9ad36b9..007f4c7 100644 --- a/src/ATrade/Driver/Real/QuoteSourceThread.hs +++ b/src/ATrade/Driver/Real/QuoteSourceThread.hs @@ -13,7 +13,6 @@ import ATrade.RoboCom.Types import ATrade.Types import Data.IORef -import Data.Maybe import qualified Data.Text as T import Control.Concurrent hiding (readChan, writeChan, @@ -58,7 +57,4 @@ startQuoteSourceThread ctx qsEp strategy eventChan agg tickFilter maybeSourceTim (datatype tick /= LastTradePrice || (datatype tick == LastTradePrice && volume tick > 0)) tickersList = fmap code . (tickers . strategyInstanceParams) $ strategy - applyTimeframeSpec t = case maybeSourceTimeframe of - Just tf -> t `T.append` T.pack (":" ++ show tf ++ ";") - Nothing -> t diff --git a/src/ATrade/Forums/Smartlab.hs b/src/ATrade/Forums/Smartlab.hs deleted file mode 100644 index ba79a14..0000000 --- a/src/ATrade/Forums/Smartlab.hs +++ /dev/null @@ -1,153 +0,0 @@ -{-# OPTIONS_GHC -Wno-type-defaults #-} - -module ATrade.Forums.Smartlab ( - NewsItem(..), - IndexItem(..), - getIndex, - getItem -) where - -import qualified Data.ByteString.Lazy as BL -import qualified Data.List as L -import Data.Maybe -import qualified Data.Text as T -import Data.Text.Encoding -import Data.Time.Calendar -import Data.Time.Clock -import Network.HTTP.Simple -import Safe -import Text.HTML.TagSoup -import Text.Parsec -import Text.Parsec.Text -import Text.StringLike - -import Debug.Trace - -data NewsItem = NewsItem { - niUrl :: !T.Text, - niHeader :: !T.Text, - niText :: !T.Text, - niAuthor :: !T.Text, - niPubTime :: !UTCTime -} deriving (Show, Eq) - -data IndexItem = IndexItem { - iiUrl :: !T.Text, - iiTitle :: !T.Text, - iiPubTime :: !UTCTime -} deriving (Show, Eq) - -monthNames :: [T.Text] -monthNames = fmap T.pack ["января", "февраля", "марта", "апреля", "мая", "июня", "июля", "августа", "сентября", "октября", "ноября", "декабря"] - -extractBetween :: StringLike str => String -> [Tag str] -> [Tag str] -extractBetween tagName = takeWhile (~/= closeTag) . dropWhile (~/= openTag) - where - openTag = "<" ++ tagName ++ ">" - closeTag = "" - -matchClass :: T.Text -> T.Text -> Tag T.Text -> Bool -matchClass _ className (TagOpen _ attrs) = case L.lookup (T.pack "class") attrs of - Just klass -> className `L.elem` T.words klass - Nothing -> False - -matchClass _ _ _ = False - -parseTimestamp :: T.Text -> Maybe UTCTime -parseTimestamp text = case parse timestampParser "" text of - Left _ -> Nothing - Right val -> Just val - where - timestampParser :: Parser UTCTime - timestampParser = do - spaces - day <- read <$> many1 digit - spaces - monthName <- T.pack <$> many1 letter - case L.elemIndex monthName monthNames of - Nothing -> fail "Can't parse month" - Just month -> do - spaces - year <- fromIntegral . read <$> many1 digit - _ <- char ',' - spaces - hour <- fromIntegral . read <$> many1 digit - _ <- char ':' - minute <- fromIntegral . read <$> many1 digit - return $ UTCTime (fromGregorian year (month + 1) day) (hour * 3600 + minute * 60) - -getItem :: IndexItem -> IO (Maybe NewsItem) -getItem indexItem = do - rq <- parseRequest $ T.unpack (iiUrl indexItem) - resp <- httpLBS rq - if getResponseStatusCode resp == 200 - then return . parseItem . decodeUtf8 . BL.toStrict . getResponseBody $ resp - else return Nothing - where - parseItem rawHtml = case parseTimestamp timestamp of - Just itemPubtime -> Just NewsItem { - niUrl = iiUrl indexItem, - niHeader = itemHeader, - niText = itemText, - niAuthor = itemAuthor, - niPubTime = itemPubtime - } - Nothing -> Nothing - where - itemHeader = innerText . - extractBetween "span" . - extractBetween "h1" . - dropWhile (not . matchClass (T.pack "div") (T.pack "topic")) $ tags - - itemText = innerText . - extractBetween "div" . - dropWhile (not . matchClass (T.pack "div") (T.pack "content")) . - dropWhile (~/= "
") $ tags - - itemAuthor = innerText . - extractBetween "li" . - dropWhile (not . matchClass (T.pack "li") (T.pack "author")) $ tags - - timestamp = traceShowId $ innerText . - extractBetween "li" . - dropWhile (not . matchClass (T.pack "li") (T.pack "date")) $ tags - - tags = parseTags rawHtml - - -getIndex :: T.Text -> Int -> IO ([IndexItem], Bool) -getIndex rootUrl pageNumber = do - rq <- parseRequest $ T.unpack $ makeUrl rootUrl pageNumber - resp <- httpLBS rq - return $ if getResponseStatusCode resp == 200 - then parseIndex . decodeUtf8 . BL.toStrict . getResponseBody $ resp - else ([], False) - where - parseIndex :: T.Text -> ([IndexItem], Bool) - parseIndex x = (mapMaybe parseIndexEntry $ partitions (matchClass (T.pack "div") (T.pack "topic")) $ parseTags x, hasNextPage $ parseTags x) - - parseIndexEntry :: [Tag T.Text] -> Maybe IndexItem - parseIndexEntry divTag = do - a <- headMay . dropWhile (~/= "") $ divTag - let text = innerText . takeWhile (~/= "") . dropWhile (~/= "") $ divTag - case a of - TagOpen _ attr -> do - href <- L.lookup (T.pack "href") attr - ts <- parseTimestamp (innerText $ takeWhile (~/= "") . dropWhile (not . matchClass (T.pack "li") (T.pack "date")) $ divTag) - Just IndexItem { iiUrl = href, - iiTitle = text, - iiPubTime = ts } - _ -> Nothing - - - makeUrl root pagenumber - | pagenumber == 0 || pagenumber == 1 = root - | otherwise = root `T.append` (T.pack "/page") `T.append` T.pack (show pagenumber) - - hasNextPage tags = if pageNumber <= 1 - then paginationLinksCount > 0 - else paginationLinksCount > 1 - where - paginationLinksCount = length . filter (~== "") . extractBetween "p" . dropWhile (~/= "