made things work with current stackage.

ibhelper.cabal

@@ -78,7 +78,18 @@ library
       TypeSynonymInstances
       ViewPatterns
       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:
   --     deps/dear-implot.hs/implot
   --     deps/dear-imgui.hs/imgui
@@ -88,7 +99,7 @@ library
   build-depends:
       StateVar
     , aeson
-    , base >=4.11 && <10
+    , base >=4.11
     , binary
     , bytestring
     , data-default
@@ -96,6 +107,7 @@ library
     , dear-implot
     , directory
     , fingertree
+    , generic-data
     , gl
     , managed
     , microlens-th
@@ -109,6 +121,7 @@ library
     , time
     , type-iso
     , unordered-containers
+    , vector
   default-language: Haskell2010
 
 executable ibhelper-exe
@@ -163,7 +176,7 @@ executable ibhelper-exe
   build-depends:
       StateVar
     , aeson
-    , base >=4.11 && <10
+    , base >=4.11
     , binary
     , bytestring
     , data-default
@@ -244,7 +257,7 @@ test-suite ibhelper-test
   build-depends:
       StateVar
     , aeson
-    , base >=4.11 && <10
+    , base >=4.11
     , binary
     , bytestring
     , data-default

src/AppFiller.hs

@@ -1,5 +1,5 @@
 {-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE OverloadedRecordDot #-}
 module AppFiller where
 
 import Import
@@ -37,19 +37,18 @@ appFiller app = runRIO app $ withRunInIO $ \run -> do
             $ 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_ErrorMsg _i _c _m)) -> debugMsg "IB_ErrorMsg not implemented"
       (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
         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
       --   let action = HM.update (\ai -> Just $ ai & accountInfo . accountLastUpdate %~ const t) n
       --   atomically $ modifyTVar' (Types.accounts currentAppData) action
       (Msg_IB_IN (IB_PortfolioValue c p mp mv ac u r n)) -> do
-        let cid = conId :: IBContract -> Int
+        let updateAction (a:as)
-            updateAction (a@IBPortfolioValue{..}:as)
+             | a._contract.conId == c.conId = IBPortfolioValue c p mp mv ac u r:as
-             | cid _contract == cid c = IBPortfolioValue c p mp mv ac u r:as
+             | otherwise                    = a:updateAction as
-             | otherwise              = a:updateAction as
             updateAction [] = [IBPortfolioValue c p mp mv ac u r]
             action = HM.update (\ai -> Just $ ai & accountPortfolio %~ updateAction) n
         atomically $ modifyTVar' (Types.accounts currentAppData) action
@@ -72,8 +71,9 @@ handleTickPrice IB_TickPrice{..} = do
         chartVar <- (HM.!s) <$> liftIO (readTVarIO charts)
         case tickType of
           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 (TimeInterval t t) price (fromIntegral size) []
+              logDebug $ displayShow ("added point", cp)
               liftIO $ atomically $ modifyTVar chartVar (\c@Chart{..} -> c { chartData = chartData |> cp, chartDirty = True})
           _ -> return ()
 handleTickPrice _ = error "impossible"

src/Chart.hs

@@ -1,57 +1,76 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedRecordDot #-}
 {-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE TupleSections #-}
 {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
-module Chart (newChart, FillerException(..), getUpdatedChartCache) where
+module Chart (newChart
+             , FillerException(..)
+             , getUpdatedChartCache
+             , getChunkedDay
+             , timePointToIndex
+             , indexToTimePoint
+             ) where
 
 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.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
-  deriving Show
+  deriving stock Show
 
 instance Exception FillerException
 
---deriving via Integer instance Hashable Day
-
 newChart :: IBContract -> RIO App ()
 newChart contract = do
   app <- ask
-  let sym = (symbol :: IBContract -> Text) contract
+  let sym = contract.symbol
-      con = (conId :: IBContract -> Int) contract
+      con = contract.conId
       hmVar = appCharts . appRefs $ app
   hm <- liftIO . readTVarIO $ hmVar
   unless (sym `HM.member` hm) $ do
     today <- liftIO getCurrentDay :: RIO App Day
     (cacheErrors, cacheData) <- do
-        files <- liftIO $ listDirectory $ "cache" </> show con
+        ifM (fmap not $ liftIO $ doesDirectoryExist $ "cache" </> show con)
-        res <- forM files $ \cacheFileName -> do
+            (return (["no data-chache found for " <> show con], [])) $ do
-          let fname = "cache" </> show con </> cacheFileName
+                files <- liftIO $ listDirectory $ "cache" </> show con
-          ifM (liftIO $ doesFileExist fname)
+                res <- forM files $ \cacheFileName -> do
-              (bimap (\err -> cacheFileName <> ": "<> err) ((readMaybe $ dropExtension cacheFileName) :: Maybe Day,) <$> liftIO (eitherDecodeFileStrict' fname))
+                  let fname = "cache" </> show con </> cacheFileName
-              (return $ Left $ "cachefile "<>cacheFileName<>" not found.")
+                  ifM (liftIO $ doesFileExist fname)
-        return $ partitionEithers res
+                      (bimap (\err -> cacheFileName <> ": "<> err) ((readMaybe $ dropExtension cacheFileName) :: Maybe Day,) <$> liftIO (eitherDecodeFileStrict' fname))
+                      (return $ Left $ "cachefile "<>cacheFileName<>" not found.")
+                return $ partitionEithers res
     unless (null cacheErrors) $ forM_ cacheErrors $ \err -> logError (displayShow err)
     let (unknownDates, cacheData') = partition (isNothing . fst) cacheData
     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 TimeInterval ChartPoint) = HM.fromList $ bimap (fromMaybe today) (FT.fromList . L.sortOn (intervalFrom . timeOfDay)) <$> 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
+    logInfo $ displayShow(fromMaybe FT.empty $ cacheData'' HM.!? today)
+    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
     liftIO $ atomically $ do
       modifyTVar' c (\Chart{..} -> let fillerThread = tid in Chart{..})
@@ -59,15 +78,15 @@ newChart contract = do
 
 fillChart :: App -> IBContract -> TVar Chart -> IO ()
 fillChart app contract cVar = runRIO app $ do
-  let sym = (symbol :: IBContract -> Text) contract
+  let sym = contract.symbol
-  (tickerMapVar :: TVar (HashMap Int Text)) <- tickerIdToSymbol. appRefs <$> ask
+  (tickerMapVar :: TVar (HashMap Int Text)) <- tickerIdToSymbol . appRefs <$> ask
   alreadyAdded <- (sym `elem`) . HM.elems <$> liftIO (readTVarIO tickerMapVar)
   unless alreadyAdded $ do
     tickerId <- (+1) . foldl' max 1000 . HM.keys <$> liftIO (readTVarIO tickerMapVar)
     let cancelSubscription = liftIO $ atomically $ do
          modifyTVar tickerMapVar (HM.delete tickerId)
          -- TODO: send cancel-request
-    let sendQ = twsConnectionSend $ twsConnectionRefs $ appRefs $ app
+    let sendQ = twsConnectionSend . twsConnectionRefs . appRefs $ app
     liftIO $ atomically $ do
       modifyTVar tickerMapVar (HM.insert tickerId sym)
       writeTQueue sendQ $ Msg_IB_OUT $ IB_RequestMktData tickerId contract "233" False False
@@ -76,40 +95,199 @@ fillChart app contract cVar = runRIO app $ do
         -- chart dirty? set clean & begin work
         c <- liftIO (readTVarIO cVar)
         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 ()
         threadDelay 1000000 -- sleep 5 seconds
 
-getUpdatedChartCache :: Chart -> Maybe ChartSettings -> (Maybe TimePoint, [ChartPoint])
+chunkChart :: Int -> Int -> Int -> FingerTree TimeInterval ChartPoint -> [(TimeInterval,[ChartPoint])]
-getUpdatedChartCache Chart{..} chartSettings' = (lUpdate, takeWhile (\ChartPoint{..} -> (\(TimePoint x) -> x < cacheUpdateStart) timeOfDay) chartCache <> map toCachePoint chunkedChart)
+chunkChart from until ticks tree = go from ticks interval
-    where (TimePoint cacheUpdateStart) = fromMaybe (TimePoint 0) Nothing -- TODO: lastCacheUpdate
+    where
-          cacheUpdateEnd   = 86400
+      traceShowCommentId' s a   = a -- traceShowCommentId s a
-          chunkChart :: Int -> Int -> Int -> FingerTree TimePoint ChartPoint -> [(TimePoint,[ChartPoint])]
+      traceShowComment'   s a b = b -- traceShowComment s a b
-          chunkChart from until range tree = go from range interval
+      interval = FT.takeUntil (\(TimeInterval x y) -> x > until)
-              where
+               . FT.dropUntil (\(TimeInterval x y) -> x >= from || (x <= from && y <= until && y >= from))
-                lastItem = case FT.viewr interval of
+               $ tree
-                            FT.EmptyR -> until
+      go f i t
-                            (_ FT.:> ChartPoint{..}) -> (\(TimePoint x) -> x) timeOfDay
+        | f >= until = traceShowCommentId' "nosplit OverNow" []
-                interval = FT.takeUntil (\(TimePoint x) -> x > until)
+        | otherwise       = let searchpred start@(TimeInterval x y) end@(TimeInterval a b)
-                         . FT.dropUntil (\(TimePoint x) -> x > from)
+                                              | start == mempty = False
-                         $ tree
+                                              | end == mempty = True
-                go f i t
+                                              | otherwise = traceShowComment' "search" (f, x, start, end) $ f+i <= x || f+2*i <= y
-                  | f+i >= lastItem = [(TimePoint (f+i), toList t)]
+                            in case FT.search searchpred t
-                  | otherwise       = let (a, b) = FT.split (\(TimePoint x) -> x > f+i) t
+                            of pos@(FT.Position l x@(ChartPoint{..}) r) 
-                                      in (TimePoint (f+i),toList a) : go (f+i) i b
+                                    | l == mempty && r == mempty && (timeIntervalBegin timeOfDay) < f+i-1 -> (traceShowCommentId' "only 1 left" $ (TimeInterval f (f+i-1), [x])) : go (f+i) i mempty
-          chunkedChart = chunkChart cacheUpdateStart cacheUpdateEnd (chartResolution $ fromMaybe chartSettings chartSettings') chartData
+                                    | l == mempty -> (traceShowComment' ("empty (" <> show f <> "," <> show (f+i) <> ")") x (TimeInterval f (f+i-1), [])) : go (f+i) i (x FT.<| r)
-          lUpdate = fmap fst . lastMaybe $ chunkedChart
+                                    | otherwise -> (traceShowComment' ("split (" <> show f <> "," <> show (f+i) <> ")") pos (FT.measure l,toList l)) : traceShowComment' "recursive call with " (f+i, i, x FT.<| r) (go (f+i) i (x FT.<| r))
-          toCachePoint :: (TimePoint,[ChartPoint]) -> ChartPoint
+                               x -> if FT.measure t == mempty then (TimeInterval f (f+i-1), []) : go (f+i) i t else traceShowCommentId' ("nosplit EndOfTree - "<> show x) [(FT.measure t, toList t)]
-          toCachePoint (t,[]) = ChartPoint t (-1) 0 []
+
-          toCachePoint (t,as) = ChartPoint t m vol [OLHC o l h c]
+-- | converts stuff returned from chunkChart into ([1 point per chunks], last point seen in the input)
+toChartData :: [ChartStudyType] -> [(TimeInterval, [ChartPoint])] -> (Maybe ChartPoint, [ChartPoint])
+toChartData studytypes chunkedChart = (lastDataPoint, foldedData)
+    where (!foldedData,lastDataPoint,_) = foldl' folder ([], Nothing, mempty) chunkedChart
+          folder :: ([ChartPoint], Maybe ChartPoint, HM.HashMap Int [Float]) -> (TimeInterval, [ChartPoint]) -> ([ChartPoint], Maybe ChartPoint, HM.HashMap Int [Float])
+          folder (acc, Nothing       , smaMap) (tp                   , [])   = (ChartPoint tp 0 0 studies:acc, Nothing, smaMap)
             where
-              vol = sum $ volume <$> as
+              studies = catMaybes $ studytypes <&> \case
-              as' = pointValue <$> as
+                  ChartStudyTypeOpen   -> Just $ OLHC 0 0 0 0
-              ms' = sum $ (\x -> pointValue x * fromIntegral (volume x)) <$> as
+                  ChartStudyTypeHigh   -> Nothing
-              m = ms' / fromIntegral vol
+                  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 0
+          folder (acc, Just lastPoint, smaMap) (tp                   , [])   = (lastPoint{ timeOfDay = tp, pointVolume = 0}:acc, Just lastPoint, foldl' (.) id smaUpdates smaMap)
+            where
+              (studies, smaUpdates) = unzip $ catMaybes $ studytypes <&> \case
+                  ChartStudyTypeOpen   -> fmap (\OLHC{..} -> (OLHC olhc_close olhc_close olhc_close olhc_close, id)) . L.find (\case OLHC{..} -> True; _ -> False) . pointExtra $ lastPoint
+                  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 0,id)
+          folder (acc, _             , smaMap) (tp@(TimeInterval f t),cdata) = (cp:acc, Just cp, foldl' (.) id smaUpdates smaMap)
+            where
+              cp = ChartPoint tp m vol studies
+              (studies, smaUpdates) = unzip $ catMaybes $ studytypes <&> \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'
+
+getUpdatedChartCache :: Chart -> Maybe ChartCacheSettings -> RIO App (Maybe TimePoint, ChartCacheData)
+getUpdatedChartCache Chart{..} chartCacheSettings' = do
+    let ccs@(ChartCacheSettings cRes cTicks) = fromMaybe chartCacheSettings chartCacheSettings'
+    now <- liftIO getCurrentTime
+    let cacheUpdateEnd   = ((utcTimeToSeconds now + cRes) `div` cRes) * cRes
+        ChartCacheData ccData ccAxis ccRange ccFill = chartCache
+    let traceShowCommentId' s a   = a -- traceShowCommentId s a
+        traceShowComment'   s a b = b -- traceShowComment s a b
+        lUpdate = utcTimeToSeconds now
+        -- - calculate Range and need for shift
+        shiftNeccessary = case ccRange of
+                            Nothing     -> False
+                            Just (TimeInterval _ 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)
+                          shift = case ccRange of
+                                  Nothing -> 0
+                                  Just (TimeInterval _ ma) -> (iTo - ma) `div` cRes
+                      in (TimeInterval iFrom iTo, shift)
+        ccAxis' = if not shiftNeccessary && isJust ccRange then ccAxis
+                  else VS.enumFromStepN (fromIntegral $ timeIntervalBegin newRange) (fromIntegral cRes) cTicks
+    let timePointToIndex' :: TimePoint -> Either String Int
+        timePointToIndex' = timePointToIndex (Just $ ChartCacheSettings cRes cTicks) newRange
+    let indexToTimePoint' :: Int -> TimePoint
+        indexToTimePoint' = indexToTimePoint (Just $ ChartCacheSettings cRes cTicks) newRange
+    when (Just newRange /= ccRange) $ logDebug $ displayShow ("range changed:", newRange, ccRange)
+    logDebug $ displayShow ("shift?" :: Text, shiftNeccessary, shiftInterval)
+    logDebug $ displayShow ("now, updateEnd, lUpdate" :: Text, utcTimeToSeconds now, cacheUpdateEnd, lUpdate)
+    let cacheUpdateStart = max (timeIntervalBegin newRange) (cacheUpdateEnd - (cRes * (cTicks+1))) -- 1 more to get history running inside the chunk-fold for fallbacks in cache if we get no data.
+    -- create data for updates
+    let chunks = case (,) <$> ccFill <*> ccRange of
+                  Nothing -> [(cacheUpdateStart, cacheUpdateEnd)]
+                  Just ((mi, ma), oldRange) -> let itp = (\(TimePoint p) -> p) . indexToTimePoint (Just ccs) oldRange in if
+                        -- Interval mi-ma already updated. get remaining intervals
+                        -- mi  ma  cUS cUE
+                      | itp ma < cacheUpdateStart -> [(cacheUpdateStart, cacheUpdateEnd)]
+                        -- mi?  cUS  mi?  ma  cUE -> [ma,cUE] + rest
+                      | itp ma < cacheUpdateEnd -> (<> [(itp ma,cacheUpdateEnd)]) if
+                          -- cUS  mi  ma
+                          | itp mi > cacheUpdateStart -> [(cacheUpdateStart, itp mi)]
+                          | otherwise -> []
+                      | otherwise -> []
+        -- - chunk them with chunhChart
+        chunkedChart = L.concat $ chunks <&> \(start, end) -> chunkChart (max 0 start) end cRes chartData
+    let (lastDataPoint, !foldedData') = toChartData (chartStudySettings chartSettings) (traceShowCommentId' "chunkedChart" chunkedChart)
+        tpToTi (TimeInterval f t) = case timePointToIndex' (TimePoint (t+f) `div` 2) of
+                                       Left e   -> error $ "BUG in Chart.hs. Impossible: " <> e
+                                       Right ti -> ti
+        -- aggregate data with index into the vectors
+        foldedData = (\cp@ChartPoint{..} -> (tpToTi timeOfDay, cp)) <$> (traceShowCommentId' "foldedData" foldedData')
+        -- 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 && shiftInterval < VS.length vec then
+                          -- TODO: unsafeSlice && unsafeUpdate_ - see #16
+                          let sliceLength = VS.length vec - shiftInterval
+                          in VS.update_
+                                (VS.update_ vec (VS.enumFromN 0 sliceLength) (VS.slice shiftInterval sliceLength vec))
+                                (VS.enumFromN sliceLength (cTicks - sliceLength))
+                                (VS.replicate sliceLength 0)
+                       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
+    logDebug $ displayShow ccData'
+    let fillRange = case traceShowCommentId' "(ccFill, lastDataPoint)" (ccFill,lastDataPoint) of
+                                          -- no new data, but different range. shift along.
+                (Just (mi,ma), Nothing) -> if ma - shiftInterval < 0 then Nothing else Just (max 0 $ mi - shiftInterval, ma - shiftInterval)
+                                          -- no data saved yet
+                (Nothing, Nothing)      -> Nothing
+                                          -- new data, update fillRange
+                (mima, Just lastDP)     -> let lastBlock = let d = timeOfDay lastDP in (intervalTo d + intervalFrom d) `div` 2
+                               in case timePointToIndex' lastBlock of
+                                    Left err -> error $ "impossible #1 Chart.hs - " <> err
+                                    Right ma -> if ma < cTicks
+                                      then case mima of  -- check if we rotated out or have no fill-range set.
+                                                Nothing        ->                                 Just (max 0 $ ma - shiftInterval, ma)
+                                                Just (mi, ma') -> if ma' - shiftInterval < 0 then Just (max 0 $ ma - shiftInterval, ma)
+                                                                                             else Just (max 0 $ mi - shiftInterval, ma)
+                                      else error $ "impossible #2 Chart.hs - " <> show ma <> ">=" <> show cTicks
+    logDebug $ displayShow fillRange
+    return (Just $ TimePoint lUpdate, ChartCacheData ccData' ccAxis' (Just newRange) fillRange)
+
+getChunkedDay :: Chart -> Maybe Int -> (Maybe TimePoint, [ChartPoint])
+getChunkedDay Chart{..} chunkResolution = case toChartData [] chunkedData of
+                                            (Nothing, x) -> (Nothing, x)
+                                            (Just ChartPoint{..}, x)
+                                              | timeOfDay == mempty -> (Nothing, x)
+                                              | otherwise -> (Just $ TimePoint $ timeIntervalEnd timeOfDay, x)
+    where
+        chunkedData = filter (not . null . snd) $ chunkChart 0 86400 (fromMaybe (chartCacheResolution chartCacheSettings) chunkResolution) chartData
+
+indexToTimePoint :: Maybe ChartCacheSettings -> TimeInterval -> Int -> TimePoint
+indexToTimePoint ccs (TimeInterval rFrom rTo) i = TimePoint $ rFrom + i*cRes
+  where
+    ChartCacheSettings cRes _ = fromMaybe defChartCacheSettings ccs
+
+timePointToIndex :: Maybe ChartCacheSettings -> TimeInterval -> TimePoint -> Either String Int
+timePointToIndex ccs (TimeInterval rFrom rTo) (TimePoint p) = if
+    | p < rFrom || p > rTo           -> Left $ "timePointToIndex " <> show ((cRes, cTicks),(rFrom, rTo),TimePoint p) <> ": " <> show p <> " out of range."
+    | result < 0 || result >= cTicks -> Left $ "timePointToIndex " <> show ((cRes, cTicks),(rFrom, rTo),TimePoint p) <> ": " <> show result <> " is invalid index"
+    | otherwise                      -> Right result
+  where
+    ChartCacheSettings cRes cTicks = fromMaybe defChartCacheSettings ccs
+    result = (p - rFrom) `div` cRes

src/IBClient/Types.hs

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

src/Import.hs

@@ -10,6 +10,9 @@ module Import
   , ppShow'
   , getCurrentDay
   , switchAccountTo
+  , utcTimeToSeconds
+  , traceShowComment
+  , traceShowCommentId
   ) where
 
 import RIO
@@ -25,6 +28,7 @@ import System.Directory
 import Data.Text as T
 import Data.Time.Clock
 import Data.Time.Calendar
+import Debug.Trace as D
 
 ppShow' :: Show a => a -> Text
 ppShow' = T.pack . ppShow
@@ -44,3 +48,12 @@ switchAccountTo a = do
     liftIO $ atomically $ writeTQueue sendQ $ Msg_IB_OUT $ IB_RequestAccountData True a
     -- finally change
     liftIO $ atomically $ modifyTVar' (currentAccount refs') (const $ Just a)
+
+utcTimeToSeconds :: UTCTime -> Int
+utcTimeToSeconds = fromInteger . (`div` ((10 :: Integer)^(12 :: Integer))) . diffTimeToPicoseconds . utctDayTime
+
+traceShowComment :: Show a => String -> a -> b -> b
+traceShowComment s a b = D.trace ("\ESC[1;31m" <> s <> ":\ESC[0m\n"<> show a<>"\n") b
+
+traceShowCommentId :: Show a => String -> a -> a
+traceShowCommentId s a = D.trace ("\ESC[1;31m" <> s <> ":\ESC[0m\n"<> show a<>"\n") a

src/Run.hs

@@ -4,27 +4,26 @@
 module Run (run) where
 
 import Import
-import Chart
 import Types
+import Chart
 import Control.Concurrent
 import Data.Aeson (encodeFile)
 import Data.Bits
 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.Tuple.Extra
+import DearImGui
+import DearImGui.OpenGL3
+import DearImGui.Plot
+import DearImGui.SDL
 import Graphics.GL
 import SDL
---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.Vector.Storable as VS
 
 import IBClient.Connection
-import Import (Chart(chartContractID))
 
 run :: RIO App ()
 run = do
@@ -52,18 +51,18 @@ shutdownApp = do
   -- save cached data
   liftIO $ unlessM (doesDirectoryExist "cache") $ createDirectory "cache"
   charts <- liftIO . readTVarIO . appCharts $ refs
-  forM_ (HM.toList charts) $ \(symbol,tc) -> do
+  forM_ (HM.toList charts) $ \(_symbol,tc) -> do
     c@Chart{..} <- liftIO . readTVarIO $ tc
     today <- liftIO $ utctDay <$> getCurrentTime
     liftIO $ unlessM (doesDirectoryExist $ "cache/" <> show chartContractID) $ createDirectory $ "cache/" <> show chartContractID
-    let (_, chartData') = getUpdatedChartCache c (Just $ ChartSettings 5 Nothing Nothing)
+    let chartData' = filter (\ChartPoint{..} -> 0 /= pointVolume) . snd $ getChunkedDay c (Just 5)
         newData = HM.toList
-                . fmap (filter (\ChartPoint{..} -> 0 /= volume))
+                . fmap (filter (\ChartPoint{..} -> 0 /= pointVolume))
-                . HM.alter (Just . maybe chartData' (<>chartData')) today
+                . HM.alter (traceShowCommentId "todays data for saving" . Just . maybe chartData' (<>chartData')) today
                 . fmap toList
                 $ chartHistData
     forM_ newData $ \(day, dat) -> do
-        liftIO $ encodeFile ("cache/" <> show chartContractID <> "/" <> show day <> ".json") dat
+        liftIO $ encodeFile ("cache/" <> show chartContractID <> "/" <> show day <> ".json") $ traceShowCommentId ("data for "<> show day) dat
   logInfo $ display $ ppShow' settings'
 
 renderLoop :: RIO App ()
@@ -165,7 +164,7 @@ renderLoop = do
               tableSetupColumn "AVG"
               tableSetupColumn "Market Value"
               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
                   tableNextRow
                   tableNextColumn $ text $ localSymbol c
@@ -203,7 +202,7 @@ renderLoop = do
                 when mustSort $ liftIO $ pPrint sortSpecs
               tableHeadersRow
               lResult <- readTVarIO $ symbolLookupResults data'
-              forM_ lResult $ \contract@IBSymbolSample{..} -> do
+              forM_ lResult $ \IBSymbolSample{..} -> do
                 let popupName = fromString $ "SymbolAction"<>show _symbolId
                 withPopup popupName $ \isPopupOpen -> do
                   when isPopupOpen $ do
@@ -232,17 +231,25 @@ renderLoop = do
           (_ :> ChartPoint{..}) -> text $ fromString $ "Last: " <> show pointValue <> "\nTime: " <> show timeOfDay
         withPlot "Test" $ do
           -- 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 $ (\(TimeInterval a b) -> (a,b)) $ fromMaybe (TimeInterval 0 86400) $ chartCacheCurrent chartCache) (-100,2500) Nothing
-          return ()
+          let ChartCacheSettings _ cTicks = chartCacheSettings
-        return ()
+              (f, t) = fromMaybe (0, cTicks-1) $ 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 (t-f < 0 || t-f >= cTicks) $ logError $ displayShow ("t/f", t-f, t, f)
+          when (isJust direct) $ do
+              plotLine (T.unpack symbol) (dataSliceLine x) (dataSliceLine $ fromJust direct)
 
 
-    -- Show the ImGui demo window
+    -- -- Show the ImGui demo window
-    showDemoWindow
+    -- showDemoWindow
-
+    --
-    -- Show the ImPlot demo window
+    -- -- Show the ImPlot demo window
-    showPlotDemoWindow
+    -- showPlotDemoWindow
 
     -- Render
     liftIO $ glClear GL_COLOR_BUFFER_BIT

src/Types.hs

@@ -17,6 +17,7 @@ import Data.Types.Injective
 import Data.Time
 import Data.FingerTree
 import Data.Semigroup
+import Generic.Data.Microsurgery
 import GHC.Generics
 import SDL (Window)
 import DearImGui
@@ -24,6 +25,7 @@ import RIO
 import RIO.Process
 import Lens.Micro.TH
 import qualified Data.Text as T
+import qualified Data.Vector.Storable as VS
 
 import IBClient.Types
 
@@ -35,7 +37,8 @@ data Options = Options
 data WindowParams = WindowParams
   { _windowWidth :: Int
   , _windowHeight :: Int
-  } deriving (Show, Generic, FromJSON, ToJSON)
+  } deriving stock (Show, Generic)
+    deriving anyclass (FromJSON, ToJSON)
 
 instance Default WindowParams where
   def = WindowParams 1024 768
@@ -43,7 +46,8 @@ instance Default WindowParams where
 data TWSConnection = TWSConnection
   { _host :: Text
   , _port :: Text
-  } deriving (Show, Generic, FromJSON, ToJSON)
+  } deriving stock (Show, Generic)
+    deriving anyclass (FromJSON, ToJSON)
 
 instance Default TWSConnection where
   def = TWSConnection "127.0.0.1" "7497"
@@ -67,7 +71,8 @@ data Settings = Settings
   { _windowParams  :: WindowParams
   , _twsConnection :: TWSConnection
   , _logLevel      :: LogLevel
-  } deriving (Show, Generic, FromJSON, ToJSON)
+  } deriving stock (Show, Generic)
+    deriving anyclass (FromJSON, ToJSON)
 
 makeLenses ''WindowParams
 makeLenses ''TWSConnection
@@ -79,7 +84,7 @@ instance Default Settings where
 data TWSConnectionStatus = TWSDisconnected
                          | TWSConnecting
                          | TWSConnected
-                         deriving (Show, Eq, Enum, Bounded)
+                         deriving stock (Show, Eq, Enum, Bounded)
 
 data TWSConnectionRefs = TWSConnectionRefs
   { twsConnectionRefsHost :: TVar Text
@@ -114,14 +119,14 @@ data IBAccount = IBAccount
                { _accountInfo       :: IBAccountInfo
                , _accountPortfolio  :: [IBPortfolioValue]
                , _accountStrategies :: [IBAccountStrategy]
-               } deriving (Show, Eq)
+               } deriving stock (Show, Eq)
 
 
 data IBAccountInfo = IBAccountInfo
                    { _accountName       :: Text
                    , _accountProperties :: HashMap Text [(Text, Text)] -- (value, currency)
                    , _accountLastUpdate :: Text
-                   } deriving (Show, Eq)
+                   } deriving stock (Show, Eq)
 
 data IBPortfolioValue = IBPortfolioValue
                       { _contract      :: IBContract
@@ -131,10 +136,11 @@ data IBPortfolioValue = IBPortfolioValue
                       , _averageCost   :: Float
                       , _unrealizedPNL :: Float
                       , _realizedPNL   :: Float
-                      } deriving (Show, Eq)
+                      } deriving stock (Show, Eq)
 
 newtype IBAccountStrategy = IBAccountStrategy [Int] -- Int -> contract-id for this strategy
-  deriving (Show, Eq)
+  deriving stock (Show)
+  deriving newtype (Eq)
 
 data IBSymbolSample = IBSymbolSample
                     { _symbolId :: Int
@@ -143,63 +149,121 @@ data IBSymbolSample = IBSymbolSample
                     , _primaryExchange :: Text
                     , _currency :: Text
                     , _derivatives :: [Text]
-                    } deriving (Show, Eq)
+                    } deriving stock (Show, Eq)
 
 makeLenses ''IBAccountStrategy
 makeLenses ''IBAccountInfo
 makeLenses ''IBAccount
 
 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 60 Nothing Nothing
+defChartSettings = ChartSettings 60 Nothing Nothing [ChartStudyTypeDirect, ChartStudyTypeVolume, ChartStudyTypeOpen]
 
--- data TimeWindow = TimeWindow
+updateChartStudySettings :: Chart -> [ChartStudyType] -> Chart
---                 { begin :: Int
+updateChartStudySettings Chart{..} s = 
---                 , end :: Int
+    let chartSettings   = chartSettings { chartStudySettings = s }
---                 } 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
+--defChartCacheSettings = ChartCacheSettings 5 20 -- for testing 
 
 -- TODO: TimePointFloat? or only 1 entry per second?
 
+data TimeInterval = TimeInterval
+                  { timeIntervalBegin :: Int
+                  , timeIntervalEnd   :: Int
+                  }
+  deriving stock (Generic, Eq)
+  deriving anyclass (FromJSON, ToJSON) -- TODO: write own instances with "TimeInterval [a,b]" instead of recods.
+  deriving (Show) via (Surgery Derecordify TimeInterval)
+instance Semigroup TimeInterval where
+  (TimeInterval mi1 ma1) <> (TimeInterval mi2 ma2)
+    = TimeInterval (getMin $ Min mi1 <> Min mi2) (getMax $ Max ma1 <> Max ma2)
+instance Monoid TimeInterval where
+  mempty = TimeInterval (getMin mempty) (getMax mempty)
+
+
 newtype TimePoint = TimePoint Int
-  deriving (Eq, Generic)
+   deriving stock (Generic, Show)
-  deriving newtype (Show, Enum, Real, Ord, Num, Integral, FromJSON, ToJSON)
+   deriving newtype (Eq, Enum, Real, Ord, Num, Integral, FromJSON, ToJSON)
-  deriving (Semigroup, Monoid) via (Max Int)
+   deriving (Semigroup, Monoid) via (Min Int)
+
+intervalFrom :: TimeInterval -> TimePoint
+intervalFrom (TimeInterval a _) = TimePoint a
+
+intervalTo :: TimeInterval -> TimePoint
+intervalTo (TimeInterval _ b) = TimePoint b
 
 data ChartStudies = SMA { window :: Int, value :: 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
-                { timeOfDay  :: TimePoint
+                { timeOfDay   :: TimeInterval
-                , 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 TimeInterval ChartPoint where
   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 TimeInterval -- ^ in number of TimeInterval, 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
-           { chartContractID :: Int
+           { chartContractID    :: Int
-           , chartData       :: FingerTree TimePoint ChartPoint -- ^ raw data (time & sale)
+           , chartData          :: FingerTree TimeInterval ChartPoint -- ^ raw data (time & sale)
-           , chartHistData   :: HashMap Day (FingerTree TimePoint ChartPoint) -- ^ raw data (time & sale)
+           , chartHistData      :: HashMap Day (FingerTree TimeInterval 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
-           } deriving (Show, Eq)
+           , chartDirty         :: Bool
+           } deriving stock (Show, Eq)
 
 newtype InjetiveGettable a b = InjetiveGettable
                           { gettable :: TVar a

stack.yaml

@@ -17,7 +17,7 @@
 #
 # resolver: ./custom-snapshot.yaml
 # resolver: https://example.com/snapshots/2018-01-01.yaml
-resolver: lts-18.24
+resolver: lts-21.2
 
 # User packages to be built.
 # Various formats can be used as shown in the example below.