Compare commits

..

2 Commits

8 changed files with 314 additions and 117 deletions

2
deps/dear-implot.hs vendored

@ -1 +1 @@
Subproject commit f3d5b63b541d8048568f134403838213c77177e4 Subproject commit 2b3810f7927a83c7cf95612497eaeceed56ca5e8

View File

@ -78,7 +78,18 @@ library
TypeSynonymInstances TypeSynonymInstances
ViewPatterns ViewPatterns
DuplicateRecordFields DuplicateRecordFields
ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -static -dynamic-too ghc-options:
-Wall
-Wcompat
-Widentities
-Wincomplete-record-updates
-Wincomplete-uni-patterns
-Wpartial-fields
-Wredundant-constraints
-Wderiving-defaults
-Wmissing-deriving-strategies
-static
-dynamic-too
-- include-dirs: -- include-dirs:
-- deps/dear-implot.hs/implot -- deps/dear-implot.hs/implot
-- deps/dear-imgui.hs/imgui -- deps/dear-imgui.hs/imgui
@ -109,6 +120,7 @@ library
, time , time
, type-iso , type-iso
, unordered-containers , unordered-containers
, vector
default-language: Haskell2010 default-language: Haskell2010
executable ibhelper-exe executable ibhelper-exe

View File

@ -37,11 +37,11 @@ appFiller app = runRIO app $ withRunInIO $ \run -> do
$ unless (L.null as) $ unless (L.null as)
$ switchAccountTo $ L.head as $ switchAccountTo $ L.head as
(Msg_IB_IN (IB_NextValidID i)) -> atomically $ modifyTVar' (nextValidID currentAppData) (const (Just i)) (Msg_IB_IN (IB_NextValidID i)) -> atomically $ modifyTVar' (nextValidID currentAppData) (const (Just i))
(Msg_IB_IN (IB_ErrorMsg i c m)) -> debugMsg "IB_ErrorMsg not implemented" (Msg_IB_IN (IB_ErrorMsg _i _c _m)) -> debugMsg "IB_ErrorMsg not implemented"
(Msg_IB_IN (IB_AccountValue k v c n)) -> do (Msg_IB_IN (IB_AccountValue k v c n)) -> do
let action = HM.update (\ai -> Just $ ai & accountInfo . accountProperties %~ HM.alter (\old -> Just $ (v,c):filter ((/=c) . snd) (fromMaybe [] old)) k) n let action = HM.update (\ai -> Just $ ai & accountInfo . accountProperties %~ HM.alter (\old -> Just $ (v,c):filter ((/=c) . snd) (fromMaybe [] old)) k) n
atomically $ modifyTVar' (Types.accounts currentAppData) action atomically $ modifyTVar' (Types.accounts currentAppData) action
(Msg_IB_IN (IB_AccountUpdateTime t)) -> debugMsg "IB_AccountUpdateTime not implemented" (Msg_IB_IN (IB_AccountUpdateTime _t)) -> debugMsg "IB_AccountUpdateTime not implemented"
-- (Msg_IB_IN (IB_AccountUpdateTime t)) -> do -- (Msg_IB_IN (IB_AccountUpdateTime t)) -> do
-- let action = HM.update (\ai -> Just $ ai & accountInfo . accountLastUpdate %~ const t) n -- let action = HM.update (\ai -> Just $ ai & accountInfo . accountLastUpdate %~ const t) n
-- atomically $ modifyTVar' (Types.accounts currentAppData) action -- atomically $ modifyTVar' (Types.accounts currentAppData) action
@ -72,8 +72,8 @@ handleTickPrice IB_TickPrice{..} = do
chartVar <- (HM.!s) <$> liftIO (readTVarIO charts) chartVar <- (HM.!s) <$> liftIO (readTVarIO charts)
case tickType of case tickType of
IBTickType_Last_Price -> do IBTickType_Last_Price -> do
t <- utctDayTime <$> liftIO getCurrentTime t <- utcTimeToSeconds <$> liftIO getCurrentTime
let cp = ChartPoint (TimePoint $ fromInteger. (`div` 1000000000000) . diffTimeToPicoseconds $ t) price size [] let cp = ChartPoint (TimePoint t) price (fromIntegral size) []
liftIO $ atomically $ modifyTVar chartVar (\c@Chart{..} -> c { chartData = chartData |> cp, chartDirty = True}) liftIO $ atomically $ modifyTVar chartVar (\c@Chart{..} -> c { chartData = chartData |> cp, chartDirty = True})
_ -> return () _ -> return ()
handleTickPrice _ = error "impossible" handleTickPrice _ = error "impossible"

View File

@ -3,32 +3,39 @@
{-# LANGUAGE DerivingVia #-} {-# LANGUAGE DerivingVia #-}
{-# LANGUAGE TupleSections #-} {-# LANGUAGE TupleSections #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
module Chart (newChart, FillerException(..), getUpdatedChartCache) where module Chart (newChart
, FillerException(..)
, getUpdatedChartCache
, getChunkedDay
, timePointToIndex
, indexToTimePoint
) where
import Import import Import
import Data.Aeson (eitherDecodeFileStrict')
import RIO.List
import RIO.List.Partial
import RIO.FilePath
import Data.Time.Calendar (Day(..))
import Data.FingerTree (FingerTree)
import Control.Concurrent (forkIO) import Control.Concurrent (forkIO)
import Control.Monad.Extra (ifM) import Control.Monad.Extra (ifM)
import qualified RIO.ByteString as BS import Data.Aeson (eitherDecodeFileStrict')
-- import Control.Exception import Data.FingerTree (FingerTree)
import qualified Data.HashMap.Strict as HM import Data.Time.Calendar (Day(..))
import qualified Data.FingerTree as FT import Data.Time.Clock
import qualified Data.Text as T import Data.Maybe (fromJust)
import RIO.FilePath
import RIO.List
import RIO.List.Partial
import qualified Debug.Trace as D import qualified Data.FingerTree as FT
import qualified Data.HashMap.Strict as HM
import qualified Data.List as L
import qualified Data.Text as T
import qualified Data.Vector.Storable as VS
--import qualified Debug.Trace as D
data FillerException = QuitFiller data FillerException = QuitFiller
deriving Show deriving stock Show
instance Exception FillerException instance Exception FillerException
--deriving via Integer instance Hashable Day
newChart :: IBContract -> RIO App () newChart :: IBContract -> RIO App ()
newChart contract = do newChart contract = do
app <- ask app <- ask
@ -39,6 +46,8 @@ newChart contract = do
unless (sym `HM.member` hm) $ do unless (sym `HM.member` hm) $ do
today <- liftIO getCurrentDay :: RIO App Day today <- liftIO getCurrentDay :: RIO App Day
(cacheErrors, cacheData) <- do (cacheErrors, cacheData) <- do
ifM (fmap not $ liftIO $ doesDirectoryExist $ "cache" </> show con)
(return $ (["no data-chache found for " <> show con], [])) $ do
files <- liftIO $ listDirectory $ "cache" </> show con files <- liftIO $ listDirectory $ "cache" </> show con
res <- forM files $ \cacheFileName -> do res <- forM files $ \cacheFileName -> do
let fname = "cache" </> show con </> cacheFileName let fname = "cache" </> show con </> cacheFileName
@ -51,7 +60,15 @@ newChart contract = do
unless (null unknownDates) $ logError $ display $ T.pack $ show (length unknownDates) <> " files had no parsable Date." unless (null unknownDates) $ logError $ display $ T.pack $ show (length unknownDates) <> " files had no parsable Date."
let cacheData'' :: HashMap Day (FingerTree TimePoint ChartPoint) = HM.fromList $ bimap (fromMaybe today) FT.fromList <$> cacheData' let cacheData'' :: HashMap Day (FingerTree TimePoint ChartPoint) = HM.fromList $ bimap (fromMaybe today) FT.fromList <$> cacheData'
logError $ displayShow $ HM.keys cacheData'' logError $ displayShow $ HM.keys cacheData''
c <- liftIO $ newTVarIO $ Chart con (fromMaybe FT.empty $ cacheData'' HM.!? today) (HM.delete today cacheData'') undefined defChartSettings [] Nothing False c <- liftIO $ newTVarIO $ Chart con
(fromMaybe FT.empty $ cacheData'' HM.!? today)
(HM.delete today cacheData'')
undefined
defChartSettings
defChartCacheSettings
(emptyChartCacheData defChartCacheSettings)
Nothing
False
tid <- liftIO $ forkIO $ fillChart app contract c tid <- liftIO $ forkIO $ fillChart app contract c
liftIO $ atomically $ do liftIO $ atomically $ do
modifyTVar' c (\Chart{..} -> let fillerThread = tid in Chart{..}) modifyTVar' c (\Chart{..} -> let fillerThread = tid in Chart{..})
@ -67,7 +84,7 @@ fillChart app contract cVar = runRIO app $ do
let cancelSubscription = liftIO $ atomically $ do let cancelSubscription = liftIO $ atomically $ do
modifyTVar tickerMapVar (HM.delete tickerId) modifyTVar tickerMapVar (HM.delete tickerId)
-- TODO: send cancel-request -- TODO: send cancel-request
let sendQ = twsConnectionSend $ twsConnectionRefs $ appRefs $ app let sendQ = twsConnectionSend . twsConnectionRefs . appRefs $ app
liftIO $ atomically $ do liftIO $ atomically $ do
modifyTVar tickerMapVar (HM.insert tickerId sym) modifyTVar tickerMapVar (HM.insert tickerId sym)
writeTQueue sendQ $ Msg_IB_OUT $ IB_RequestMktData tickerId contract "233" False False writeTQueue sendQ $ Msg_IB_OUT $ IB_RequestMktData tickerId contract "233" False False
@ -76,18 +93,14 @@ fillChart app contract cVar = runRIO app $ do
-- chart dirty? set clean & begin work -- chart dirty? set clean & begin work
c <- liftIO (readTVarIO cVar) c <- liftIO (readTVarIO cVar)
when (chartDirty c) $ do when (chartDirty c) $ do
liftIO $ atomically $ modifyTVar cVar (\c -> c { chartDirty = False }) liftIO $ atomically $ modifyTVar cVar (\c' -> c' { chartDirty = False })
let (lUpdate, cachePoints) = getUpdatedChartCache c Nothing (lUpdate, cachePoints) <- getUpdatedChartCache c Nothing
liftIO $ atomically $ modifyTVar cVar (\c -> c { chartCache = cachePoints, lastCacheUpdate = lUpdate }) liftIO $ atomically $ modifyTVar cVar (\c' -> c' { chartCache = cachePoints, lastCacheUpdate = lUpdate })
return () return ()
threadDelay 1000000 -- sleep 5 seconds threadDelay 1000000 -- sleep 5 seconds
getUpdatedChartCache :: Chart -> Maybe ChartSettings -> (Maybe TimePoint, [ChartPoint]) chunkChart :: Int -> Int -> Int -> FingerTree TimePoint ChartPoint -> [(TimePoint,[ChartPoint])]
getUpdatedChartCache Chart{..} chartSettings' = (lUpdate, takeWhile (\ChartPoint{..} -> (\(TimePoint x) -> x < cacheUpdateStart) timeOfDay) chartCache <> map toCachePoint chunkedChart) chunkChart from until range tree = go from range interval
where (TimePoint cacheUpdateStart) = fromMaybe (TimePoint 0) Nothing -- TODO: lastCacheUpdate
cacheUpdateEnd = 86400
chunkChart :: Int -> Int -> Int -> FingerTree TimePoint ChartPoint -> [(TimePoint,[ChartPoint])]
chunkChart from until range tree = go from range interval
where where
lastItem = case FT.viewr interval of lastItem = case FT.viewr interval of
FT.EmptyR -> until FT.EmptyR -> until
@ -99,17 +112,135 @@ getUpdatedChartCache Chart{..} chartSettings' = (lUpdate, takeWhile (\ChartPoint
| f+i >= lastItem = [(TimePoint (f+i), toList t)] | f+i >= lastItem = [(TimePoint (f+i), toList t)]
| otherwise = let (a, b) = FT.split (\(TimePoint x) -> x > f+i) t | otherwise = let (a, b) = FT.split (\(TimePoint x) -> x > f+i) t
in (TimePoint (f+i),toList a) : go (f+i) i b in (TimePoint (f+i),toList a) : go (f+i) i b
chunkedChart = chunkChart cacheUpdateStart cacheUpdateEnd (chartResolution $ fromMaybe chartSettings chartSettings') chartData
lUpdate = fmap fst . lastMaybe $ chunkedChart toCachePoint :: (TimePoint,[ChartPoint]) -> ChartPoint
toCachePoint :: (TimePoint,[ChartPoint]) -> ChartPoint toCachePoint (t,[]) = ChartPoint t (-1) 0 []
toCachePoint (t,[]) = ChartPoint t (-1) 0 [] toCachePoint (t,as) = ChartPoint t m vol [OLHC o l h c]
toCachePoint (t,as) = ChartPoint t m vol [OLHC o l h c]
where where
vol = sum $ volume <$> as vol = sum $ pointVolume <$> as
as' = pointValue <$> as as' = pointValue <$> as
ms' = sum $ (\x -> pointValue x * fromIntegral (volume x)) <$> as ms' = sum $ (\x -> pointValue x * pointVolume x) <$> as
m = ms' / fromIntegral vol m = ms' / vol
o = head as' o = head as'
c = last as' c = last as'
l = minimum as' l = minimum as'
h = maximum as' h = maximum as'
getUpdatedChartCache :: Chart -> Maybe ChartCacheSettings -> RIO App (Maybe TimePoint, ChartCacheData)
getUpdatedChartCache Chart{..} chartCacheSettings' = do
let ChartCacheSettings cRes cTicks = fromMaybe chartCacheSettings chartCacheSettings'
now <- liftIO getCurrentTime
-- - recalculate cacheUpdateStart & cacheUpdateEnd
let cacheUpdateEnd = ((utcTimeToSeconds now + cRes) `div` cRes) * cRes
cacheUpdateStart = cacheUpdateEnd - (cRes * cTicks)
ChartCacheData ccData ccAxis ccRange ccFill = chartCache
chunks = case ccFill of
Nothing -> [(cacheUpdateStart, cacheUpdateEnd)]
Just (mi, ma) -> if
-- Interval mi-ma already updated. get remaining intervals
-- mi ma cUS cUE
| ma < cacheUpdateStart -> [(cacheUpdateStart, cacheUpdateEnd)]
-- mi? cUS mi? ma cUE -> [ma,cUE] + rest
| ma < cacheUpdateEnd -> [(ma,cacheUpdateEnd)] <> if
-- cUS mi ma
| mi > cacheUpdateStart -> [(cacheUpdateStart, mi)]
| otherwise -> []
| otherwise -> []
-- - chunk them with chunhChart
chunkedChart = L.filter (not . null . snd) $ L.concat $ for chunks $ \(start, end) -> chunkChart (min 0 start) end cRes chartData
lUpdate = cacheUpdateEnd - cRes
-- - calculate Range and need for shift
shiftNeccessary = case ccRange of
Nothing -> False
Just (_,ma) -> cacheUpdateEnd > ma
(newRange, shiftInterval) = if not shiftNeccessary && isJust ccRange then (fromJust ccRange, 0) else
let interval = cTicks `div` 20 :: Int
iTo = ((cacheUpdateEnd + cRes * interval) `div` (cRes * interval)) * (cRes * interval)
iFrom = iTo - 20 * (cRes * interval)
in ((iFrom,iTo), interval)
ccAxis' = if not shiftNeccessary && isJust ccRange then ccAxis
else VS.enumFromStepN (fromIntegral $ fst newRange) (fromIntegral cRes) cTicks
logDebug $ displayShow ("now, updateEnd, lUpdate" :: Text, utcTimeToSeconds now, cacheUpdateEnd, lUpdate)
-- create data for updates
let timePointToIndex' :: TimePoint -> Int
timePointToIndex' = timePointToIndex (Just $ ChartCacheSettings cRes cTicks) newRange
let indexToTimePoint' :: Int -> TimePoint
indexToTimePoint' = indexToTimePoint (Just $ ChartCacheSettings cRes cTicks) newRange
-- fold instead of map, so we can carry over cached calculatinos from element to element (for i.e. ema/sma)
let (!foldedData,_,_) = foldl' folder ([], ChartPoint 0 0 0 [], mempty) chunkedChart
folder :: ([(Int, ChartPoint)], ChartPoint, HM.HashMap Int [Float]) -> (TimePoint, [ChartPoint]) -> ([(Int, ChartPoint)], ChartPoint, HM.HashMap Int [Float])
folder old (_,[]) = old
folder (acc, lastPoint, smaMap) (tp,cdata) = ((timePointToIndex' tp, cp):acc, cp, foldl' (.) id smaUpdates smaMap)
where
cp = ChartPoint tp m vol studies
(studies, smaUpdates) = unzip $ catMaybes $ (chartStudySettings chartSettings :: [ChartStudyType]) <&> \case
ChartStudyTypeOpen -> Just (OLHC o l h c, id)
ChartStudyTypeHigh -> Nothing
ChartStudyTypeLow -> Nothing
ChartStudyTypeClose -> Nothing
ChartStudyTypeDirect -> Nothing
ChartStudyTypeSMA w -> Nothing --TODO: fixme #13, do the calculation & use data inside smaMap and return (SMA x y, smaUpdate)
ChartStudyTypeVolume -> Just (Volume vol, id)
vol = sum $ pointVolume <$> cdata
as' = pointValue <$> cdata
ms' = sum $ (\x -> pointValue x * pointVolume x) <$> cdata
m = ms' / vol
o = head as'
c = last as'
l = minimum as'
h = maximum as'
-- plan the actual work
updates = chartStudySettings chartSettings <&> \cs ->
-- check if thing is in hashmap
let vec = case ccData HM.!? cs of
Nothing -> VS.replicate cTicks 0
Just a -> a
-- shift if neccessary
vec' = if shiftNeccessary && cs `HM.member` ccData then
-- TODO: unsafeSlice && unsafeUpdate_ - see #16
let sliceLength = VS.length vec - shiftInterval
in VS.update_ vec (VS.enumFromN 0 sliceLength) (VS.slice shiftInterval sliceLength vec)
else
vec
-- NOW:
-- newRange is (rangeFrom, rangeTo) in seconds with 0 being last midnight
-- vec' has that range mapped to indices [0,cTicks-1] with every cRes being one time-slice
-- everything in the chunkedChart-list has to be inserted if in range using the same time-notation like the range
-- (hint: chunkedChart is (time, [data]), with time being the point at the end of each contained interval)
findOLHC as = fromJust $ find (\case OLHC{} -> True; _ -> False) as
findVolume as = fromJust $ find (\case Volume{} -> True; _ -> False) as
in case cs of
ChartStudyTypeDirect -> HM.insert cs (vec' VS.// ((\(i, ChartPoint _ x _ _) -> (i,x)) <$> foldedData))
ChartStudyTypeOpen -> HM.insert cs (vec' VS.// ((\(i, ChartPoint _ _ _ s) -> (i,olhc_open $ findOLHC s)) <$> foldedData))
ChartStudyTypeLow -> HM.insert cs (vec' VS.// ((\(i, ChartPoint _ _ _ s) -> (i,olhc_low $ findOLHC s)) <$> foldedData))
ChartStudyTypeHigh -> HM.insert cs (vec' VS.// ((\(i, ChartPoint _ _ _ s) -> (i,olhc_high $ findOLHC s)) <$> foldedData))
ChartStudyTypeClose -> HM.insert cs (vec' VS.// ((\(i, ChartPoint _ _ _ s) -> (i,olhc_close $ findOLHC s)) <$> foldedData))
ChartStudyTypeSMA x -> id --TODO: implement #13
ChartStudyTypeVolume -> HM.insert cs (vec' VS.// ((\(i, ChartPoint _ _ _ s) -> (i,volume $ findVolume s)) <$> foldedData))
let ccData' = foldl' (.) id updates ccData
-- logInfo $ displayShow chartCache
-- logInfo $ displayShow (cacheUpdateStart, cacheUpdateEnd)
-- logInfo $ displayShow (newRange, chunkedChart)
let ma = timePointToIndex' $ TimePoint lUpdate
mi = fromMaybe ma $ fst <$> ccFill
return (Just $ TimePoint lUpdate, ChartCacheData ccData' ccAxis' (Just newRange) (Just $ (mi, timePointToIndex' $ TimePoint lUpdate)))
getChunkedDay :: Chart -> Maybe Int -> (Maybe TimePoint, [ChartPoint])
getChunkedDay Chart{..} chunkResolution = (lUpdate, toCachePoint <$> chunkedData)
where
chunkedData = chunkChart 0 86400 (fromMaybe (chartCacheResolution chartCacheSettings) chunkResolution) chartData
lUpdate = fmap fst . lastMaybe $ chunkedData
indexToTimePoint :: Maybe ChartCacheSettings -> (Int, Int) -> Int -> TimePoint
indexToTimePoint ccs (rFrom, rTo) i = TimePoint $ rFrom + i*cRes
where
ChartCacheSettings cRes _ = fromMaybe defChartCacheSettings ccs
timePointToIndex :: Maybe ChartCacheSettings -> (Int, Int) -> TimePoint -> Int
timePointToIndex ccs (rFrom, rTo) (TimePoint p) = if
| p < rFrom || p > rTo -> error $ "timePointToIndex " <> show ((cRes, cTicks),(rFrom, rTo),TimePoint p) <> ": " <> show p <> " out of range."
| result < 0 || result >= cTicks -> error $ "timePointToIndex " <> show ((cRes, cTicks),(rFrom, rTo),TimePoint p) <> ": " <> show result <> " is invalid index"
| otherwise -> result
where
ChartCacheSettings cRes cTicks = fromMaybe defChartCacheSettings ccs
result = (p - rFrom) `div` cRes

View File

@ -44,7 +44,8 @@ toBS (IBBool False) = "0"--BS.pack [0,0,0,0] -- bool == 32-bit int in IB
newtype IBGenericMessage = IBGenericMessage newtype IBGenericMessage = IBGenericMessage
{ fields :: [IBTypes] { fields :: [IBTypes]
} deriving (Show, Eq) } deriving stock (Show)
deriving newtype (Eq)
instance Binary IBGenericMessage where instance Binary IBGenericMessage where
put (IBGenericMessage f) = do put (IBGenericMessage f) = do

View File

@ -10,6 +10,7 @@ module Import
, ppShow' , ppShow'
, getCurrentDay , getCurrentDay
, switchAccountTo , switchAccountTo
, utcTimeToSeconds
) where ) where
import RIO import RIO
@ -44,3 +45,6 @@ switchAccountTo a = do
liftIO $ atomically $ writeTQueue sendQ $ Msg_IB_OUT $ IB_RequestAccountData True a liftIO $ atomically $ writeTQueue sendQ $ Msg_IB_OUT $ IB_RequestAccountData True a
-- finally change -- finally change
liftIO $ atomically $ modifyTVar' (currentAccount refs') (const $ Just a) liftIO $ atomically $ modifyTVar' (currentAccount refs') (const $ Just a)
utcTimeToSeconds :: UTCTime -> Int
utcTimeToSeconds = fromInteger . (`div` ((10 :: Integer)^(12 :: Integer))) . diffTimeToPicoseconds . utctDayTime

View File

@ -4,27 +4,26 @@
module Run (run) where module Run (run) where
import Import import Import
import Chart
import Types import Types
import Chart
import Control.Concurrent import Control.Concurrent
import Data.Aeson (encodeFile) import Data.Aeson (encodeFile)
import Data.Bits import Data.Bits
import Data.FingerTree (ViewL(..), ViewR(..), viewl, viewr, split, FingerTree) import Data.FingerTree (ViewL(..), ViewR(..), viewl, viewr, split, FingerTree)
import DearImGui import Data.Maybe (fromJust)
import DearImGui.Plot
import DearImGui.OpenGL3
import DearImGui.SDL
import Data.Time.Clock import Data.Time.Clock
import Data.Tuple.Extra
import DearImGui
import DearImGui.OpenGL3
import DearImGui.Plot
import DearImGui.SDL
import Graphics.GL import Graphics.GL
import SDL import SDL
--import Data.StateVar
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.List as L
import qualified Data.HashMap.Strict as HM import qualified Data.HashMap.Strict as HM
--import qualified Data.FingerTree as FT import qualified Data.Vector.Storable as VS
import IBClient.Connection import IBClient.Connection
import Import (Chart(chartContractID))
run :: RIO App () run :: RIO App ()
run = do run = do
@ -52,13 +51,13 @@ shutdownApp = do
-- save cached data -- save cached data
liftIO $ unlessM (doesDirectoryExist "cache") $ createDirectory "cache" liftIO $ unlessM (doesDirectoryExist "cache") $ createDirectory "cache"
charts <- liftIO . readTVarIO . appCharts $ refs charts <- liftIO . readTVarIO . appCharts $ refs
forM_ (HM.toList charts) $ \(symbol,tc) -> do forM_ (HM.toList charts) $ \(_symbol,tc) -> do
c@Chart{..} <- liftIO . readTVarIO $ tc c@Chart{..} <- liftIO . readTVarIO $ tc
today <- liftIO $ utctDay <$> getCurrentTime today <- liftIO $ utctDay <$> getCurrentTime
liftIO $ unlessM (doesDirectoryExist $ "cache/" <> show chartContractID) $ createDirectory $ "cache/" <> show chartContractID liftIO $ unlessM (doesDirectoryExist $ "cache/" <> show chartContractID) $ createDirectory $ "cache/" <> show chartContractID
let (_, chartData') = getUpdatedChartCache c (Just $ ChartSettings 5 Nothing Nothing) let (_, chartData') = getChunkedDay c (Just 5)
newData = HM.toList newData = HM.toList
. fmap (filter (\ChartPoint{..} -> 0 /= volume)) . fmap (filter (\ChartPoint{..} -> 0 /= pointVolume))
. HM.alter (Just . maybe chartData' (<>chartData')) today . HM.alter (Just . maybe chartData' (<>chartData')) today
. fmap toList . fmap toList
$ chartHistData $ chartHistData
@ -165,7 +164,7 @@ renderLoop = do
tableSetupColumn "AVG" tableSetupColumn "AVG"
tableSetupColumn "Market Value" tableSetupColumn "Market Value"
tableHeadersRow tableHeadersRow
forM_ ((accs HM.! aid) ^.. accountPortfolio . traverse) $ \(IBPortfolioValue c p mp mv ac up rp) -> forM_ ((accs HM.! aid) ^.. accountPortfolio . traverse) $ \(IBPortfolioValue c p mp mv _ac up rp) ->
do do
tableNextRow tableNextRow
tableNextColumn $ text $ localSymbol c tableNextColumn $ text $ localSymbol c
@ -203,7 +202,7 @@ renderLoop = do
when mustSort $ liftIO $ pPrint sortSpecs when mustSort $ liftIO $ pPrint sortSpecs
tableHeadersRow tableHeadersRow
lResult <- readTVarIO $ symbolLookupResults data' lResult <- readTVarIO $ symbolLookupResults data'
forM_ lResult $ \contract@IBSymbolSample{..} -> do forM_ lResult $ \IBSymbolSample{..} -> do
let popupName = fromString $ "SymbolAction"<>show _symbolId let popupName = fromString $ "SymbolAction"<>show _symbolId
withPopup popupName $ \isPopupOpen -> do withPopup popupName $ \isPopupOpen -> do
when isPopupOpen $ do when isPopupOpen $ do
@ -232,9 +231,17 @@ renderLoop = do
(_ :> ChartPoint{..}) -> text $ fromString $ "Last: " <> show pointValue <> "\nTime: " <> show timeOfDay (_ :> ChartPoint{..}) -> text $ fromString $ "Last: " <> show pointValue <> "\nTime: " <> show timeOfDay
withPlot "Test" $ do withPlot "Test" $ do
-- TODO: set axes -- TODO: set axes
let (x,y) = L.unzip $ (\ChartPoint{..} -> (fromIntegral timeOfDay,pointValue)) <$> chartCache -- let (x,y) = L.unzip $ (\ChartPoint{..} -> (fromIntegral timeOfDay,pointValue)) <$> chartCache
plotLine (T.unpack symbol) x y setupAxisLimits (both fromIntegral $ fromMaybe (0,86400) $ chartCacheCurrent chartCache) (-100,2500) Nothing
return () let ChartCacheSettings _ cTicks = chartCacheSettings
(f, t) = fromMaybe (0, cTicks) $ chartCacheFilledTo chartCache
direct = chartCacheData chartCache HM.!? ChartStudyTypeDirect
x = chartCacheAxis chartCache
-- t-f == 0 means there is still 1 point in it. VS.slice takes number of points as second argument. Add 1!
-- dataSlice = VS.slice f (t-f+1)
dataSliceLine = if t-f < 1 then VS.slice (max 0 $ f-1) 2 else VS.slice f (t-f+1) -- need at least 2 points to make a line... duh!
when (isJust direct) $ do
plotLine (T.unpack symbol) (dataSliceLine x) (dataSliceLine $ fromJust direct)
return () return ()

View File

@ -24,6 +24,7 @@ import RIO
import RIO.Process import RIO.Process
import Lens.Micro.TH import Lens.Micro.TH
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Vector.Storable as VS
import IBClient.Types import IBClient.Types
@ -35,7 +36,8 @@ data Options = Options
data WindowParams = WindowParams data WindowParams = WindowParams
{ _windowWidth :: Int { _windowWidth :: Int
, _windowHeight :: Int , _windowHeight :: Int
} deriving (Show, Generic, FromJSON, ToJSON) } deriving stock (Show, Generic)
deriving anyclass (FromJSON, ToJSON)
instance Default WindowParams where instance Default WindowParams where
def = WindowParams 1024 768 def = WindowParams 1024 768
@ -43,7 +45,8 @@ instance Default WindowParams where
data TWSConnection = TWSConnection data TWSConnection = TWSConnection
{ _host :: Text { _host :: Text
, _port :: Text , _port :: Text
} deriving (Show, Generic, FromJSON, ToJSON) } deriving stock (Show, Generic)
deriving anyclass (FromJSON, ToJSON)
instance Default TWSConnection where instance Default TWSConnection where
def = TWSConnection "127.0.0.1" "7497" def = TWSConnection "127.0.0.1" "7497"
@ -67,7 +70,8 @@ data Settings = Settings
{ _windowParams :: WindowParams { _windowParams :: WindowParams
, _twsConnection :: TWSConnection , _twsConnection :: TWSConnection
, _logLevel :: LogLevel , _logLevel :: LogLevel
} deriving (Show, Generic, FromJSON, ToJSON) } deriving stock (Show, Generic)
deriving anyclass (FromJSON, ToJSON)
makeLenses ''WindowParams makeLenses ''WindowParams
makeLenses ''TWSConnection makeLenses ''TWSConnection
@ -79,7 +83,7 @@ instance Default Settings where
data TWSConnectionStatus = TWSDisconnected data TWSConnectionStatus = TWSDisconnected
| TWSConnecting | TWSConnecting
| TWSConnected | TWSConnected
deriving (Show, Eq, Enum, Bounded) deriving stock (Show, Eq, Enum, Bounded)
data TWSConnectionRefs = TWSConnectionRefs data TWSConnectionRefs = TWSConnectionRefs
{ twsConnectionRefsHost :: TVar Text { twsConnectionRefsHost :: TVar Text
@ -114,14 +118,14 @@ data IBAccount = IBAccount
{ _accountInfo :: IBAccountInfo { _accountInfo :: IBAccountInfo
, _accountPortfolio :: [IBPortfolioValue] , _accountPortfolio :: [IBPortfolioValue]
, _accountStrategies :: [IBAccountStrategy] , _accountStrategies :: [IBAccountStrategy]
} deriving (Show, Eq) } deriving stock (Show, Eq)
data IBAccountInfo = IBAccountInfo data IBAccountInfo = IBAccountInfo
{ _accountName :: Text { _accountName :: Text
, _accountProperties :: HashMap Text [(Text, Text)] -- (value, currency) , _accountProperties :: HashMap Text [(Text, Text)] -- (value, currency)
, _accountLastUpdate :: Text , _accountLastUpdate :: Text
} deriving (Show, Eq) } deriving stock (Show, Eq)
data IBPortfolioValue = IBPortfolioValue data IBPortfolioValue = IBPortfolioValue
{ _contract :: IBContract { _contract :: IBContract
@ -131,10 +135,11 @@ data IBPortfolioValue = IBPortfolioValue
, _averageCost :: Float , _averageCost :: Float
, _unrealizedPNL :: Float , _unrealizedPNL :: Float
, _realizedPNL :: Float , _realizedPNL :: Float
} deriving (Show, Eq) } deriving stock (Show, Eq)
newtype IBAccountStrategy = IBAccountStrategy [Int] -- Int -> contract-id for this strategy newtype IBAccountStrategy = IBAccountStrategy [Int] -- Int -> contract-id for this strategy
deriving (Show, Eq) deriving stock (Show)
deriving newtype (Eq)
data IBSymbolSample = IBSymbolSample data IBSymbolSample = IBSymbolSample
{ _symbolId :: Int { _symbolId :: Int
@ -143,7 +148,7 @@ data IBSymbolSample = IBSymbolSample
, _primaryExchange :: Text , _primaryExchange :: Text
, _currency :: Text , _currency :: Text
, _derivatives :: [Text] , _derivatives :: [Text]
} deriving (Show, Eq) } deriving stock (Show, Eq)
makeLenses ''IBAccountStrategy makeLenses ''IBAccountStrategy
makeLenses ''IBAccountInfo makeLenses ''IBAccountInfo
@ -153,53 +158,90 @@ data ChartSettings = ChartSettings
{ chartResolution :: Int { chartResolution :: Int
, chartStart :: Maybe UTCTime , chartStart :: Maybe UTCTime
, chartEnd :: Maybe UTCTime , chartEnd :: Maybe UTCTime
} deriving (Show, Eq) , chartStudySettings :: [ChartStudyType]
} deriving stock (Show, Eq)
defChartSettings :: ChartSettings defChartSettings :: ChartSettings
defChartSettings = ChartSettings 60 Nothing Nothing defChartSettings = ChartSettings 60 Nothing Nothing [ChartStudyTypeDirect]
-- data TimeWindow = TimeWindow updateChartStudySettings :: Chart -> [ChartStudyType] -> Chart
-- { begin :: Int updateChartStudySettings Chart{..} s =
-- , end :: Int let chartSettings = chartSettings { chartStudySettings = [] }
-- } deriving (Show, Eq) chartCache = emptyChartCacheData chartCacheSettings
lastCacheUpdate = Nothing
in Chart{..}
-- | Settings for Chart-cache.
-- --
-- instance Semigroup TimeWindow where -- History and Resolution yield 1 day by default. Do not increase over 5000 as memery-consumption explodes!
-- (TimeWindow a b) <> (TimeWindow x y) = TimeWindow (min a x) (max b y) -- Think of it as timePlotted = candleWidth * numberOfCandles
-- --
-- instance Monoid TimeWindow where -- chartCacheHistory should be a multiple of 20 as there often is 5% buffer in various caches and this
-- mempty = TimeWindow 0 86400 -- fills the caches more optimally
data ChartCacheSettings = ChartCacheSettings
{ chartCacheResolution :: Int
, chartCacheHistory :: Int
} deriving stock (Show, Eq)
defChartCacheSettings :: ChartCacheSettings
defChartCacheSettings = ChartCacheSettings 60 1440
-- TODO: TimePointFloat? or only 1 entry per second? -- TODO: TimePointFloat? or only 1 entry per second?
newtype TimePoint = TimePoint Int newtype TimePoint = TimePoint Int
deriving (Eq, Generic) deriving stock (Generic)
deriving newtype (Show, Enum, Real, Ord, Num, Integral, FromJSON, ToJSON) deriving newtype (Show, Eq, Enum, Real, Ord, Num, Integral, FromJSON, ToJSON)
deriving (Semigroup, Monoid) via (Max Int) deriving (Semigroup, Monoid) via (Max Int)
data ChartStudies = SMA { window :: Int, value :: Float } data ChartStudies = SMA { window :: Int, value :: Float }
| OLHC { olhc_open :: Float, olhc_low :: Float, olhc_high :: Float, olhc_close :: Float} | OLHC { olhc_open :: Float, olhc_low :: Float, olhc_high :: Float, olhc_close :: Float}
deriving (Show, Eq, Generic, FromJSON, ToJSON) | Volume { volume :: Float }
deriving stock (Show, Eq, Generic)
deriving anyclass (FromJSON, ToJSON)
data ChartPoint = ChartPoint data ChartPoint = ChartPoint
{ timeOfDay :: TimePoint { timeOfDay :: TimePoint
, pointValue :: Float , pointValue :: Float
, volume :: Int , pointVolume :: Float
, pointExtra :: [ChartStudies] , pointExtra :: [ChartStudies]
} deriving (Show, Eq, Generic, FromJSON, ToJSON) } deriving stock (Show, Eq, Generic)
deriving anyclass (FromJSON, ToJSON)
instance Measured TimePoint ChartPoint where instance Measured TimePoint ChartPoint where
measure = timeOfDay measure = timeOfDay
-- | Tick-based data
data ChartStudyType = ChartStudyTypeDirect
| ChartStudyTypeSMA Int
| ChartStudyTypeOpen
| ChartStudyTypeLow
| ChartStudyTypeHigh
| ChartStudyTypeClose
| ChartStudyTypeVolume
deriving stock (Show, Eq, Generic)
deriving anyclass (Hashable)
data ChartCacheData = ChartCacheData
{ chartCacheData :: HashMap ChartStudyType (VS.Vector Float)
, chartCacheAxis :: VS.Vector Float
, chartCacheCurrent :: Maybe (Int,Int) -- ^ in number of TimePoint, negative meaning "before today"
, chartCacheFilledTo :: Maybe (Int,Int) -- ^ in index into the vectors given range of "Current"
} deriving stock (Show, Eq)
emptyChartCacheData :: ChartCacheSettings -> ChartCacheData
emptyChartCacheData ChartCacheSettings{..} = ChartCacheData mempty (VS.replicate chartCacheHistory 0) Nothing Nothing
data Chart = Chart data Chart = Chart
{ chartContractID :: Int { chartContractID :: Int
, chartData :: FingerTree TimePoint ChartPoint -- ^ raw data (time & sale) , chartData :: FingerTree TimePoint ChartPoint -- ^ raw data (time & sale)
, chartHistData :: HashMap Day (FingerTree TimePoint ChartPoint) -- ^ raw data (time & sale) , chartHistData :: HashMap Day (FingerTree TimePoint ChartPoint) -- ^ raw data (time & sale)
, fillerThread :: ThreadId , fillerThread :: ThreadId
, chartSettings :: ChartSettings , chartSettings :: ChartSettings
, chartCache :: [ChartPoint] -- ^ cache for drawing with all pointExtra filled out and sampled according to 'chartSettings' , chartCacheSettings :: ChartCacheSettings
, chartCache :: ChartCacheData -- ^ cache for drawing with all pointExtra filled out and sampled according to 'chartSettings'
, lastCacheUpdate :: Maybe TimePoint , lastCacheUpdate :: Maybe TimePoint
, chartDirty :: Bool , chartDirty :: Bool
} deriving (Show, Eq) } deriving stock (Show, Eq)
newtype InjetiveGettable a b = InjetiveGettable newtype InjetiveGettable a b = InjetiveGettable
{ gettable :: TVar a { gettable :: TVar a