bugfix(*): fix performance issues

src/Main.hs

@@ -13,6 +13,7 @@ import           Control.Exception
 import           Control.Monad
 import           Data.Aeson
 import qualified Data.ByteString.Lazy           as B
+import           Data.IORef
 import qualified Data.List                      as L
 import qualified Data.Map.Strict                as M
 import qualified Graphics.Vty                   as Vty
@@ -29,22 +30,30 @@ import           QuoteTable
 data Name = Viewport1
   deriving (Show, Eq, Ord)
 
-data AppEvent = IncomingTick Tick
+data AppEvent = QuoteTableUpdate QuoteTable
 
 data AppState = AppState {
   _quotes :: QuoteTable
-} deriving (Show, Eq)
+}
 
 makeLenses ''AppState
 
-qsThread :: BChan AppEvent -> AppConfig -> IO ()
+qsThread :: IORef QuoteTable -> AppConfig -> IO ()
-qsThread eventChan config = withContext $ \ctx -> do
+qsThread quotetable config = withContext $ \ctx -> do
   qschan <- BC.newBoundedChan 1000
   bracket (startQuoteSourceClient qschan (config ^. tickers) ctx (config ^. quoteSourceEndpoint) defaultClientSecurityParams) stopQuoteSourceClient $ \_ -> forever $ do
     qsdata <- BC.readChan qschan
     case qsdata of
-      QDTick tick -> writeBChan eventChan (IncomingTick tick)
+      QDTick tick -> handleNewTick quotetable tick
       _           -> return ()
+  where
+    handleNewTick s t = atomicModifyIORef s $ \table -> (updateTable table t, ())
+
+quoteTableWriterThread :: IORef QuoteTable -> BChan AppEvent -> IO ()
+quoteTableWriterThread qtRef chan = forever $ do
+  threadDelay 1000000
+  qt <- readIORef qtRef
+  writeBChan chan $ QuoteTableUpdate qt
 
 
 main :: IO ()
@@ -60,13 +69,15 @@ main = do
                 appStartEvent = startEvent,
                 appAttrMap = attrMap'
                     }
+      quoteTableRef <- newIORef M.empty
       eventChan <- Brick.BChan.newBChan 10
       let buildVty = Vty.mkVty Vty.defaultConfig
       initialVty <- buildVty
-      qsThreadId <- forkIO $ qsThread eventChan config
+      qsThreadId <- forkIO $ qsThread quoteTableRef config
-      void $ customMain buildVty (Just eventChan) app initialState
+      qtwThreadId <- forkIO $ quoteTableWriterThread quoteTableRef eventChan
+      void $ customMain buildVty (Just eventChan) app (initialState M.empty)
   where
-    initialState = AppState M.empty
+    initialState ref = AppState ref
     draw :: AppState -> [Widget Name]
     draw s = [hBox . L.intersperse vBorder $ hLimit 15 . padLeftRight 3 <$> [vBox ([str "Ticker", hBorder] ++ (txt <$> tickers s)),
                     vBox ([str "Last", hBorder] ++ (str <$> fmap (printEntry s qteLastPrice) (tickers s))),
@@ -82,12 +93,7 @@ main = do
         Vty.EvKey (Vty.KChar 'q') [] -> halt s
         _                            -> continue s
       AppEvent e -> case e of
-        IncomingTick t -> continue $ handleNewTick s t
+        QuoteTableUpdate t -> continue $ AppState t
       _ -> continue s
     startEvent = return
     attrMap' s = attrMap Vty.defAttr []
-    handleNewTick s t = case datatype t of
-      LastTradePrice -> s & quotes . at (security t) . non emptyQuoteTableEntry . qteLastPrice .~ value t
-      BestBid -> s & quotes . at (security t) . non emptyQuoteTableEntry . qteBid .~ value t
-      BestOffer -> s & quotes . at (security t) . non emptyQuoteTableEntry . qteAsk .~ value t
-      _ -> s

src/QuoteTable.hs

@@ -7,7 +7,8 @@ module QuoteTable
     qteLastPrice,
     qteBid,
     qteAsk,
-    emptyQuoteTableEntry
+    emptyQuoteTableEntry,
+    updateTable
   ) where
 
 import           ATrade.Types
@@ -30,3 +31,11 @@ emptyQuoteTableEntry = QuoteTableEntry 0 0 0
 
 type QuoteTable = M.Map TickerId QuoteTableEntry
 
+updateTable :: QuoteTable -> Tick -> QuoteTable
+updateTable table t = case datatype t of
+  LastTradePrice -> table & at (security t) . non emptyQuoteTableEntry . qteLastPrice .~ value t
+  BestBid -> table & at (security t) . non emptyQuoteTableEntry . qteBid .~ value t
+  BestOffer -> table & at (security t) . non emptyQuoteTableEntry . qteAsk .~ value t
+  _ -> table
+
+