implemented #5
This commit is contained in:
parent
1848f0f2fc
commit
971f9d1651
|
|
@ -7,3 +7,4 @@ settings.json
|
|||
*.lock
|
||||
tags
|
||||
dist-newstyle/
|
||||
cache/*
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
Subproject commit ad5fdc1e646947c1365e725d29a43fc96dc98a66
|
||||
Subproject commit 49539fc1ba04c590af0718066ce7a9aead8ff336
|
||||
|
|
@ -99,6 +99,7 @@ library
|
|||
, gl
|
||||
, managed
|
||||
, microlens-th
|
||||
, extra
|
||||
, network
|
||||
, pretty-show
|
||||
, rio >=0.1.12.0
|
||||
|
|
|
|||
|
|
@ -11,7 +11,7 @@ import Data.Time
|
|||
import Data.FingerTree
|
||||
import Data.HashMap.Strict ((!?))
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
|
||||
import qualified Data.List as L
|
||||
|
||||
import qualified Debug.Trace as D
|
||||
|
||||
|
|
@ -28,11 +28,14 @@ appFiller app = runRIO app $ withRunInIO $ \run -> do
|
|||
(Msg_IB_IN (IB_ManagedAccts as)) -> do
|
||||
cur <- readTVarIO $ Types.accounts currentAppData
|
||||
actions <- forM as $ \a -> case cur !? a of
|
||||
Just _ -> return $ id
|
||||
Just _ -> return id
|
||||
Nothing -> do
|
||||
debugMsg $ "added Account "<> a
|
||||
return $ HM.insertWith const a (mkIBAccount a)
|
||||
atomically $ modifyTVar (Types.accounts currentAppData) $ foldl' (.) id actions
|
||||
run $ whenM (ask >>= (fmap isNothing . readTVarIO) . currentAccount . appRefs)
|
||||
$ unless (L.null as)
|
||||
$ switchAccountTo $ L.head as
|
||||
(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_AccountValue k v c n)) -> do
|
||||
|
|
@ -58,7 +61,6 @@ appFiller app = runRIO app $ withRunInIO $ \run -> do
|
|||
_ -> --D.trace ("not implemented in AppFiller:" <> show input) $
|
||||
infoMsg $ "not implemented in AppFiller:" <> T.pack (show input)
|
||||
|
||||
|
||||
handleTickPrice :: IB_IN -> RIO App ()
|
||||
handleTickPrice IB_TickPrice{..} = do
|
||||
charts <- appCharts . appRefs <$> ask
|
||||
|
|
@ -71,7 +73,7 @@ handleTickPrice IB_TickPrice{..} = do
|
|||
case tickType of
|
||||
IBTickType_Last_Price -> do
|
||||
t <- utctDayTime <$> liftIO getCurrentTime
|
||||
let cp = ChartPoint (TimePoint $ fromInteger. (`div` 1000000000000) . diffTimeToPicoseconds $ t) price []
|
||||
let cp = ChartPoint (TimePoint $ fromInteger. (`div` 1000000000000) . diffTimeToPicoseconds $ t) price size []
|
||||
liftIO $ atomically $ modifyTVar chartVar (\c@Chart{..} -> c { chartData = chartData |> cp, chartDirty = True})
|
||||
_ -> return ()
|
||||
handleTickPrice _ = error "impossible"
|
||||
|
|
|
|||
83
src/Chart.hs
83
src/Chart.hs
|
|
@ -2,18 +2,21 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE DerivingVia #-}
|
||||
module Chart (newChart, FillerException(..)) where
|
||||
module Chart (newChart, FillerException(..), getUpdatedChartCache) where
|
||||
|
||||
import Import
|
||||
import Data.Time
|
||||
import Data.Aeson (eitherDecodeFileStrict')
|
||||
import RIO.List
|
||||
import RIO.List.Partial
|
||||
import Data.Time.Calendar (Day(..))
|
||||
import Data.FingerTree (FingerTree)
|
||||
import Control.Concurrent (forkIO)
|
||||
import Control.Monad.Extra (ifM)
|
||||
import qualified RIO.ByteString as BS
|
||||
-- import Control.Exception
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
import qualified Data.FingerTree as FT
|
||||
import qualified Data.Text as T
|
||||
|
||||
import qualified Debug.Trace as D
|
||||
|
||||
|
|
@ -28,10 +31,20 @@ newChart :: IBContract -> RIO App ()
|
|||
newChart contract = do
|
||||
app <- ask
|
||||
let sym = (symbol :: IBContract -> Text) contract
|
||||
con = (conId :: IBContract -> Int) contract
|
||||
hmVar = appCharts . appRefs $ app
|
||||
hm <- liftIO . readTVarIO $ hmVar
|
||||
unless (sym `HM.member` hm) $ do
|
||||
c <- liftIO $ newTVarIO $ Chart FT.empty mempty undefined defChartSettings [] Nothing False
|
||||
let cacheFileName = "cache/"<> show con <>".json"
|
||||
today <- liftIO getCurrentDay
|
||||
cacheData <- liftIO $ ifM (doesFileExist cacheFileName)
|
||||
(eitherDecodeFileStrict' cacheFileName)
|
||||
(return $ Left $ "cachefile "<>cacheFileName<>" not found.")
|
||||
(cacheData' :: HashMap Day (FingerTree TimePoint ChartPoint)) <- case cacheData of
|
||||
Left err -> logError (display (T.pack $ "Error opening "<>cacheFileName<>".\n") <> displayShow err)
|
||||
>> return HM.empty
|
||||
Right (d :: HashMap Day [ChartPoint]) -> return $ FT.fromList <$> d
|
||||
c <- liftIO $ newTVarIO $ Chart con (fromMaybe FT.empty $ cacheData' HM.!? today) mempty undefined defChartSettings [] Nothing False
|
||||
tid <- liftIO $ forkIO $ fillChart app contract c
|
||||
liftIO $ atomically $ do
|
||||
modifyTVar' c (\Chart{..} -> let fillerThread = tid in Chart{..})
|
||||
|
|
@ -54,36 +67,42 @@ fillChart app contract cVar = runRIO app $ do
|
|||
handle (\QuitFiller -> cancelSubscription >> exitSuccess) $
|
||||
forever $ do
|
||||
-- chart dirty? set clean & begin work
|
||||
Chart{..} <- liftIO (readTVarIO cVar)
|
||||
when chartDirty $ do
|
||||
c <- liftIO (readTVarIO cVar)
|
||||
when (chartDirty c) $ do
|
||||
liftIO $ atomically $ modifyTVar cVar (\c -> c { chartDirty = False })
|
||||
let (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
|
||||
lastItem = case FT.viewr interval of
|
||||
FT.EmptyR -> until
|
||||
(_ FT.:> ChartPoint{..}) -> (\(TimePoint x) -> x) timeOfDay
|
||||
interval = FT.takeUntil (\(TimePoint x) -> x > until)
|
||||
. FT.dropUntil (\(TimePoint x) -> x > from)
|
||||
$ tree
|
||||
go f i t
|
||||
| f+i >= lastItem = [(TimePoint (f+i), toList t)]
|
||||
| otherwise = let (a, b) = FT.split (\(TimePoint x) -> x > f+i) t
|
||||
in (TimePoint (f+i),toList a) : go (f+i) i b
|
||||
chunkedChart = chunkChart cacheUpdateStart cacheUpdateEnd (chartResolution chartSettings) chartData
|
||||
cachePoints = takeWhile (\ChartPoint{..} -> (\(TimePoint x) -> x < cacheUpdateStart) timeOfDay) chartCache <> map toCachePoint chunkedChart
|
||||
toCachePoint :: (TimePoint,[ChartPoint]) -> ChartPoint
|
||||
toCachePoint (t,[]) = ChartPoint t (-1) []
|
||||
toCachePoint (t,as) = ChartPoint t c [OLHC o l h c]
|
||||
where
|
||||
as' = pointValue <$> as
|
||||
o = head as'
|
||||
c = last as'
|
||||
l = minimum as'
|
||||
h = maximum as'
|
||||
let lUpdate = fmap fst . lastMaybe $ chunkedChart
|
||||
let (lUpdate, cachePoints) = getUpdatedChartCache c Nothing
|
||||
liftIO $ atomically $ modifyTVar cVar (\c -> c { chartCache = cachePoints, lastCacheUpdate = lUpdate })
|
||||
return ()
|
||||
threadDelay 1000000 -- sleep 5 seconds
|
||||
|
||||
getUpdatedChartCache :: Chart -> Maybe ChartSettings -> (Maybe TimePoint, [ChartPoint])
|
||||
getUpdatedChartCache Chart{..} chartSettings' = (lUpdate, takeWhile (\ChartPoint{..} -> (\(TimePoint x) -> x < cacheUpdateStart) timeOfDay) chartCache <> map toCachePoint chunkedChart)
|
||||
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
|
||||
lastItem = case FT.viewr interval of
|
||||
FT.EmptyR -> until
|
||||
(_ FT.:> ChartPoint{..}) -> (\(TimePoint x) -> x) timeOfDay
|
||||
interval = FT.takeUntil (\(TimePoint x) -> x > until)
|
||||
. FT.dropUntil (\(TimePoint x) -> x > from)
|
||||
$ tree
|
||||
go f i t
|
||||
| f+i >= lastItem = [(TimePoint (f+i), toList t)]
|
||||
| otherwise = let (a, b) = FT.split (\(TimePoint x) -> x > f+i) t
|
||||
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 (t,[]) = ChartPoint t (-1) 0 []
|
||||
toCachePoint (t,as) = ChartPoint t m vol [OLHC o l h c]
|
||||
where
|
||||
vol = sum $ volume <$> as
|
||||
as' = pointValue <$> as
|
||||
ms' = sum $ (\x -> pointValue x * fromIntegral (volume x)) <$> as
|
||||
m = ms' / fromIntegral vol
|
||||
o = head as'
|
||||
c = last as'
|
||||
l = minimum as'
|
||||
h = maximum as'
|
||||
|
|
|
|||
|
|
@ -6,7 +6,10 @@ module Import
|
|||
, module Data.Default
|
||||
, module Text.Show.Pretty
|
||||
, module IBClient.Types
|
||||
, module System.Directory
|
||||
, ppShow'
|
||||
, getCurrentDay
|
||||
, switchAccountTo
|
||||
) where
|
||||
|
||||
import RIO
|
||||
|
|
@ -15,10 +18,29 @@ import Data.Aeson (FromJSON, ToJSON)
|
|||
import Data.Default
|
||||
import Text.Show.Pretty
|
||||
import IBClient.Types
|
||||
import System.Directory
|
||||
|
||||
|
||||
--- imports not reexported
|
||||
import Data.Text as T
|
||||
import Data.Time.Clock
|
||||
import Data.Time.Calendar
|
||||
|
||||
ppShow' :: Show a => a -> Text
|
||||
ppShow' = T.pack . ppShow
|
||||
|
||||
getCurrentDay :: IO Day
|
||||
getCurrentDay = utctDay <$> getCurrentTime
|
||||
|
||||
switchAccountTo :: Text -> RIO App ()
|
||||
switchAccountTo a = do
|
||||
refs' <- appRefs <$> ask
|
||||
let sendQ = twsConnectionSend $ twsConnectionRefs refs'
|
||||
-- cancel subscription of old account (if any)
|
||||
readTVarIO (currentAccount refs') >>= \case
|
||||
Nothing -> return ()
|
||||
Just aid -> liftIO $ atomically $ writeTQueue sendQ $ Msg_IB_OUT $ IB_RequestAccountData False aid
|
||||
-- subscribe to new account
|
||||
liftIO $ atomically $ writeTQueue sendQ $ Msg_IB_OUT $ IB_RequestAccountData True a
|
||||
-- finally change
|
||||
liftIO $ atomically $ modifyTVar' (currentAccount refs') (const $ Just a)
|
||||
|
|
|
|||
37
src/Run.hs
37
src/Run.hs
|
|
@ -14,14 +14,17 @@ import DearImGui
|
|||
import DearImGui.Plot
|
||||
import DearImGui.OpenGL3
|
||||
import DearImGui.SDL
|
||||
import Data.Time.Clock
|
||||
import Graphics.GL
|
||||
import SDL
|
||||
import Data.StateVar
|
||||
--import Data.StateVar
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.List as L
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
import qualified Data.FingerTree as FT
|
||||
--import qualified Data.FingerTree as FT
|
||||
|
||||
import IBClient.Connection
|
||||
import Import (Chart(chartContractID))
|
||||
|
||||
run :: RIO App ()
|
||||
run = do
|
||||
|
|
@ -47,7 +50,18 @@ shutdownApp = do
|
|||
liftIO $ encodeFile "settings.json" settings'
|
||||
logInfo $ display ("Settings Saved" :: Text)
|
||||
-- save cached data
|
||||
|
||||
liftIO $ unlessM (doesDirectoryExist "cache") $ createDirectory "cache"
|
||||
charts <- liftIO . readTVarIO . appCharts $ refs
|
||||
forM_ (HM.toList charts) $ \(symbol,tc) -> do
|
||||
c@Chart{..} <- liftIO . readTVarIO $ tc
|
||||
today <- liftIO $ utctDay <$> getCurrentTime
|
||||
let (_, chartData') = getUpdatedChartCache c (Just $ ChartSettings 5 Nothing Nothing)
|
||||
merge a b = a <> b --TODO: merge duplicates!
|
||||
newData = HM.alter (\case
|
||||
Just t -> Just (merge t chartData')
|
||||
Nothing -> Just chartData') today (toList <$> chartHistData)
|
||||
newData' = filter (\ChartPoint{..} -> 0 /= volume) <$> newData
|
||||
liftIO $ encodeFile ("cache/"<> show chartContractID <>".json") newData'
|
||||
logInfo $ display $ ppShow' settings'
|
||||
|
||||
renderLoop :: RIO App ()
|
||||
|
|
@ -91,15 +105,7 @@ renderLoop = do
|
|||
forM_ accs $ \a -> do
|
||||
selectable a >>= \case
|
||||
False -> return ()
|
||||
True -> do
|
||||
-- cancel subscription of old account (if any)
|
||||
readTVarIO (currentAccount refs') >>= \case
|
||||
Nothing -> return ()
|
||||
Just aid -> liftIO $ atomically $ writeTQueue sendQ $ Msg_IB_OUT $ IB_RequestAccountData False aid
|
||||
-- subscribe to new account
|
||||
liftIO $ atomically $ writeTQueue sendQ $ Msg_IB_OUT $ IB_RequestAccountData True a
|
||||
-- finally change
|
||||
liftIO $ atomically $ modifyTVar' (currentAccount refs') (const $ Just a)
|
||||
True -> switchAccountTo a
|
||||
let cStatus = twsConnectionStatus cr
|
||||
connHost <- liftIO $ readTVarIO $ twsConnectionRefsHost cr
|
||||
connPort <- liftIO $ readTVarIO $ twsConnectionRefsPort cr
|
||||
|
|
@ -222,8 +228,11 @@ renderLoop = do
|
|||
case viewr chartData of
|
||||
EmptyR -> text "no last price"
|
||||
(_ :> ChartPoint{..}) -> text $ fromString $ "Last: " <> show pointValue <> "\nTime: " <> show timeOfDay
|
||||
text $ ppShow' chartCache
|
||||
text $ ppShow' lastCacheUpdate
|
||||
withPlot "Test" $ do
|
||||
-- TODO: set axes
|
||||
let (x,y) = L.unzip $ (\ChartPoint{..} -> (fromIntegral timeOfDay,pointValue)) <$> chartCache
|
||||
plotLine (T.unpack symbol) x y
|
||||
return ()
|
||||
return ()
|
||||
|
||||
|
||||
|
|
|
|||
18
src/Types.hs
18
src/Types.hs
|
|
@ -169,30 +169,34 @@ defChartSettings = ChartSettings 60 Nothing Nothing
|
|||
-- instance Monoid TimeWindow where
|
||||
-- mempty = TimeWindow 0 86400
|
||||
|
||||
-- TODO: TimePointFloat? or only 1 entry per second?
|
||||
|
||||
newtype TimePoint = TimePoint Int
|
||||
deriving Eq
|
||||
deriving newtype Show
|
||||
deriving (Eq, Generic)
|
||||
deriving newtype (Show, Enum, Real, Ord, Num, Integral, FromJSON, ToJSON)
|
||||
deriving (Semigroup, Monoid) via (Max Int)
|
||||
|
||||
data ChartStudies = SMA { window :: Int, value :: Float }
|
||||
| OLHC { olhc_open :: Float, olhc_low :: Float, olhc_high :: Float, olhc_close :: Float}
|
||||
deriving (Show, Eq)
|
||||
deriving (Show, Eq, Generic, FromJSON, ToJSON)
|
||||
|
||||
data ChartPoint = ChartPoint
|
||||
{ timeOfDay :: TimePoint
|
||||
, pointValue :: Float
|
||||
, volume :: Int
|
||||
, pointExtra :: [ChartStudies]
|
||||
} deriving (Show, Eq)
|
||||
} deriving (Show, Eq, Generic, FromJSON, ToJSON)
|
||||
|
||||
instance Measured TimePoint ChartPoint where
|
||||
measure = timeOfDay
|
||||
|
||||
data Chart = Chart
|
||||
{ chartData :: FingerTree TimePoint ChartPoint
|
||||
, chartHistData :: HashMap Day (FingerTree TimePoint ChartPoint)
|
||||
{ chartContractID :: Int
|
||||
, chartData :: FingerTree TimePoint ChartPoint -- ^ raw data (time & sale)
|
||||
, chartHistData :: HashMap Day (FingerTree TimePoint ChartPoint) -- ^ raw data (time & sale)
|
||||
, fillerThread :: ThreadId
|
||||
, chartSettings :: ChartSettings
|
||||
, chartCache :: [ChartPoint]
|
||||
, chartCache :: [ChartPoint] -- ^ cache for drawing with all pointExtra filled out and sampled according to 'chartSettings'
|
||||
, lastCacheUpdate :: Maybe TimePoint
|
||||
, chartDirty :: Bool
|
||||
} deriving (Show, Eq)
|
||||
|
|
|
|||
Loading…
Reference in New Issue