Drezil/ibhelper
1
1
Fork 0
Code Issues 12 Pull Requests Projects Releases Wiki Activity

#12 compiles, but untested

Browse Source
This commit is contained in:
Nicole Dresselhaus 2022-08-04 05:25:46 +02:00
parent fcf8c26137
commit 16b4eb83e1
7 changed files with 233 additions and 89 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
ibhelper.cabal
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

8
src/AppFiller.hs
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"

191
src/Chart.hs
View File

@ -3,32 +3,33 @@
{-# 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) 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
@ -51,7 +52,7 @@ 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 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 +68,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,40 +77,136 @@ 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 where
cacheUpdateEnd = 86400 lastItem = case FT.viewr interval of
chunkChart :: Int -> Int -> Int -> FingerTree TimePoint ChartPoint -> [(TimePoint,[ChartPoint])] FT.EmptyR -> until
chunkChart from until range tree = go from range interval (_ FT.:> ChartPoint{..}) -> (\(TimePoint x) -> x) timeOfDay
where interval = FT.takeUntil (\(TimePoint x) -> x > until)
lastItem = case FT.viewr interval of . FT.dropUntil (\(TimePoint x) -> x > from)
FT.EmptyR -> until $ tree
(_ FT.:> ChartPoint{..}) -> (\(TimePoint x) -> x) timeOfDay go f i t
interval = FT.takeUntil (\(TimePoint x) -> x > until) | f+i >= lastItem = [(TimePoint (f+i), toList t)]
. FT.dropUntil (\(TimePoint x) -> x > from) | otherwise = let (a, b) = FT.split (\(TimePoint x) -> x > f+i) t
$ tree in (TimePoint (f+i),toList a) : go (f+i) i b
go f i t
| f+i >= lastItem = [(TimePoint (f+i), toList t)] toCachePoint :: (TimePoint,[ChartPoint]) -> ChartPoint
| otherwise = let (a, b) = FT.split (\(TimePoint x) -> x > f+i) t toCachePoint (t,[]) = ChartPoint t (-1) 0 []
in (TimePoint (f+i),toList a) : go (f+i) i b toCachePoint (t,as) = ChartPoint t m vol [OLHC o l h c]
chunkedChart = chunkChart cacheUpdateStart cacheUpdateEnd (chartResolution $ fromMaybe chartSettings chartSettings') chartData where
lUpdate = fmap fst . lastMaybe $ chunkedChart vol = sum $ pointVolume <$> as
toCachePoint :: (TimePoint,[ChartPoint]) -> ChartPoint as' = pointValue <$> as
toCachePoint (t,[]) = ChartPoint t (-1) 0 [] ms' = sum $ (\x -> pointValue x * pointVolume x) <$> as
toCachePoint (t,as) = ChartPoint t m vol [OLHC o l h c] m = ms' / vol
o = head as'
c = last as'
l = minimum as'
h = maximum as'
getUpdatedChartCache :: MonadIO m => Chart -> Maybe ChartCacheSettings -> m (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
cacheUpdateStart = cacheUpdateEnd - (cRes * cTicks)
ChartCacheData ccData 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.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 + 20) `div` 20 :: Int
iTo = (cacheUpdateEnd + cRes * interval) `div` (cRes * interval)
iFrom = iTo - 20 * (cRes * interval)
in ((iFrom,iTo), interval)
-- create data for updates
let timePointToIndex' :: (Int, Int) -> (Int, Int) -> TimePoint -> Int
timePointToIndex' (cRes', cTicks') (rFrom, rTo) (TimePoint p) = let result = (p - rFrom) `div` cRes in
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
timePointToIndex :: TimePoint -> Int
timePointToIndex = timePointToIndex' newRange (cRes, cTicks)
-- fold instead of map, so we can carry over cached calculatinos from element to element (for i.e. ema/sma)
(!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 where
vol = sum $ volume <$> as cp = ChartPoint tp m vol studies
as' = pointValue <$> as (studies, smaUpdates) = unzip $ catMaybes $ (chartStudySettings chartSettings :: [ChartStudyType]) <&> \case
ms' = sum $ (\x -> pointValue x * fromIntegral (volume x)) <$> as ChartStudyTypeOpen -> Just (OLHC o l h c, id)
m = ms' / fromIntegral vol 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' o = head as'
c = last as' c = last as'
l = minimum as' l = minimum as'
h = maximum 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))
return (Just $ TimePoint lUpdate, ChartCacheData (foldl' (.) id updates ccData) (Just newRange) Nothing) -- FIXME: fillData still missing
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

3
src/IBClient/Types.hs
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

4
src/Import.hs
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

15
src/Run.hs
View File

@ -24,7 +24,6 @@ import qualified Data.HashMap.Strict as HM
--import qualified Data.FingerTree as FT --import qualified Data.FingerTree as FT
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,8 +231,8 @@ 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 -- plotLine (T.unpack symbol) x y
return () return ()
return () return ()

87
src/Types.hs
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
@ -134,7 +135,7 @@ data IBPortfolioValue = IBPortfolioValue
} deriving (Show, Eq) } deriving (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 newtype (Show, Eq)
data IBSymbolSample = IBSymbolSample data IBSymbolSample = IBSymbolSample
{ _symbolId :: Int { _symbolId :: Int
@ -150,55 +151,85 @@ makeLenses ''IBAccountInfo
makeLenses ''IBAccount makeLenses ''IBAccount
data ChartSettings = ChartSettings data ChartSettings = ChartSettings
{ chartResolution :: Int { chartResolution :: Int
, chartStart :: Maybe UTCTime , chartStart :: Maybe UTCTime
, chartEnd :: Maybe UTCTime , chartEnd :: Maybe UTCTime
, chartStudySettings :: [ChartStudyType]
} deriving (Show, Eq) } deriving (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
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
-- data ChartCacheSettings = ChartCacheSettings
-- instance Monoid TimeWindow where { chartCacheResolution :: Int
-- mempty = TimeWindow 0 86400 , 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}
| Volume { volume :: Float }
deriving (Show, Eq, Generic, FromJSON, ToJSON) deriving (Show, Eq, Generic, 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 (Show, Eq, Generic, FromJSON, ToJSON)
instance Measured TimePoint ChartPoint where instance Measured TimePoint ChartPoint where
measure = timeOfDay measure = timeOfDay
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)
, chartCacheCurrent :: Maybe (Int,Int) -- ^ in number of TimePoint, negative meaning "before today"
, chartCacheFilled :: Maybe (Int,Int) -- ^ in number of TimePoint, negative meaning "before today"
} deriving stock (Show, Eq)
emptyChartCacheData :: ChartCacheData
emptyChartCacheData = ChartCacheData mempty 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
, lastCacheUpdate :: Maybe TimePoint , chartCache :: ChartCacheData -- ^ cache for drawing with all pointExtra filled out and sampled according to 'chartSettings'
, chartDirty :: Bool , lastCacheUpdate :: Maybe TimePoint
, chartDirty :: Bool
} deriving (Show, Eq) } deriving (Show, Eq)
newtype InjetiveGettable a b = InjetiveGettable newtype InjetiveGettable a b = InjetiveGettable