From 980c309281dcd66cdc7d873d333120ca67647353 Mon Sep 17 00:00:00 2001 From: Stefan Dresselhaus Date: Tue, 19 Jul 2022 23:07:01 +0200 Subject: [PATCH] compiles and works again. --- app/Main.hs | 4 ++-- cabal.project | 8 ++++--- deps/dear-implot.hs | 2 +- ibhelper.cabal | 19 ++++++++------- package.yaml | 2 +- src/IBClient/Connection.hs | 2 +- src/Import.hs | 8 +++++++ src/Run.hs | 48 +++++++++++++++++++------------------- src/Types.hs | 10 ++++---- 9 files changed, 58 insertions(+), 45 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 12a152d..bf02be6 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -77,8 +77,8 @@ main = do -- Initialize ImGui's OpenGL backend _ <- managed_ $ bracket_ openGL3Init openGL3Shutdown - twsConnectionRefsHost <- liftIO $ atomically $ newTVar $ settings ^. twsConnection . host . to T.unpack - twsConnectionRefsPort <- liftIO $ atomically $ newTVar $ settings ^. twsConnection . port . to T.unpack + twsConnectionRefsHost <- liftIO $ atomically $ newTVar $ settings ^. twsConnection . host + twsConnectionRefsPort <- liftIO $ atomically $ newTVar $ settings ^. twsConnection . port twsConnectionStatus <- liftIO $ atomically $ newTVar $ TWSDisconnected twsConnectionSend <- liftIO $ atomically $ newTQueue twsConnectionRecieve <- liftIO $ atomically $ newTQueue diff --git a/cabal.project b/cabal.project index 16ecf02..fad8e3b 100644 --- a/cabal.project +++ b/cabal.project @@ -2,6 +2,8 @@ packages: deps/dear-imgui.hs deps/dear-implot.hs *.cabal package ibhelper - ghc-options: -Wall -Wcompat -fno-warn-unused-do-bind -shared: false -static: true + ghc-options: -Wall -Wcompat -fno-warn-unused-do-bind -g3 +package dear-imgui + ghc-options: -g3 -dynamic +package dear-implot + ghc-options: -g3 -dynamic diff --git a/deps/dear-implot.hs b/deps/dear-implot.hs index c06c3d2..c6a3005 160000 --- a/deps/dear-implot.hs +++ b/deps/dear-implot.hs @@ -1 +1 @@ -Subproject commit c06c3d266587545240b4fde6e33bcc67d16a871a +Subproject commit c6a30057c3059ec7b579fc00c3da21a2bc1a35f7 diff --git a/ibhelper.cabal b/ibhelper.cabal index 7de8a3b..4528050 100644 --- a/ibhelper.cabal +++ b/ibhelper.cabal @@ -78,12 +78,13 @@ library TypeSynonymInstances ViewPatterns DuplicateRecordFields - ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -dynamic include-dirs: deps/dear-implot.hs/implot deps/dear-imgui.hs/imgui extra-libraries: - HSdear-imgui-1.4.0-inplace + HSdear-imgui-2.0.0-inplace-ghc8.10.7 + HSdear-implot-1.0.0-inplace-ghc8.10.7 build-depends: StateVar , aeson @@ -91,7 +92,7 @@ library , binary , bytestring , data-default - , dear-imgui >=1.4.0 + , dear-imgui >=2.0.0 , dear-implot , directory , fingertree @@ -154,12 +155,13 @@ executable ibhelper-exe TypeSynonymInstances ViewPatterns DuplicateRecordFields - ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N -dynamic include-dirs: deps/dear-implot.hs/implot deps/dear-imgui.hs/imgui extra-libraries: - HSdear-imgui-1.4.0-inplace + HSdear-imgui-2.0.0-inplace-ghc8.10.7 + HSdear-implot-1.0.0-inplace-ghc8.10.7 build-depends: StateVar , aeson @@ -167,7 +169,7 @@ executable ibhelper-exe , binary , bytestring , data-default - , dear-imgui >=1.4.0 + , dear-imgui >=2.0.0 , dear-implot , directory , fingertree @@ -239,7 +241,8 @@ test-suite ibhelper-test deps/dear-implot.hs/implot deps/dear-imgui.hs/imgui extra-libraries: - HSdear-imgui-1.4.0-inplace + HSdear-imgui-2.0.0-inplace-ghc8.10.7 + HSdear-implot-1.0.0-inplace-ghc8.10.7 build-depends: StateVar , aeson @@ -247,7 +250,7 @@ test-suite ibhelper-test , binary , bytestring , data-default - , dear-imgui >=1.4.0 + , dear-imgui >=2.0.0 , dear-implot , directory , fingertree diff --git a/package.yaml b/package.yaml index 3e951dc..4711168 100644 --- a/package.yaml +++ b/package.yaml @@ -24,7 +24,7 @@ include-dirs: - deps/dear-imgui.hs/imgui extra-libraries: - - HSdear-imgui-1.4.0-inplace + - HSdear-imgui-2.0.0-inplace-ghc8.10.7 default-extensions: - BangPatterns diff --git a/src/IBClient/Connection.hs b/src/IBClient/Connection.hs index 60292b5..ff27aa5 100644 --- a/src/IBClient/Connection.hs +++ b/src/IBClient/Connection.hs @@ -25,7 +25,7 @@ forkClient app = runRIO app $ withRunInIO $ \run -> withSocketsDo $ do connPort <- readTVarIO $ twsConnectionRefsPort refs atomically $ modifyTVar' cStatus (const TWSConnecting) -- TODO: throws IO-Exeption instead of returning empty list -> handle! - addr:_ <- getAddrInfo (Just $ defaultHints { addrFlags = [AI_NUMERICHOST, AI_NUMERICSERV], addrProtocol = 0, addrSocketType = Stream}) (Just connHost) (Just connPort) + addr:_ <- getAddrInfo (Just $ defaultHints { addrFlags = [AI_NUMERICHOST, AI_NUMERICSERV], addrProtocol = 0, addrSocketType = Stream}) (Just $ T.unpack connHost) (Just $ T.unpack connPort) run $ logDebug $ displayShow addr E.bracketOnError (socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)) close $ \sock -> do connect sock $ addrAddress addr diff --git a/src/Import.hs b/src/Import.hs index 4eba0e4..1074f73 100644 --- a/src/Import.hs +++ b/src/Import.hs @@ -6,6 +6,7 @@ module Import , module Data.Default , module Text.Show.Pretty , module IBClient.Types + , ppShow' ) where import RIO @@ -14,3 +15,10 @@ import Data.Aeson (FromJSON, ToJSON) import Data.Default import Text.Show.Pretty import IBClient.Types + + +--- imports not reexported +import Data.Text as T + +ppShow' :: Show a => a -> Text +ppShow' = T.pack . ppShow diff --git a/src/Run.hs b/src/Run.hs index 6e0b675..638ec5b 100644 --- a/src/Run.hs +++ b/src/Run.hs @@ -35,20 +35,20 @@ shutdownApp :: RIO App () shutdownApp = do win <- appWindow <$> ask -- save settings & config - (V2 w h) <- liftIO $ get $ windowSize win + (V2 w h) <- liftIO $ get $ windowSize win settings <- appSettings <$> ask refs <- appRefs <$> ask host' <- liftIO . readTVarIO . twsConnectionRefsHost . twsConnectionRefs $ refs port' <- liftIO . readTVarIO . twsConnectionRefsPort . twsConnectionRefs $ refs let settings' = settings & windowParams . windowWidth .~ fromIntegral w & windowParams . windowHeight .~ fromIntegral h - & twsConnection . host .~ T.pack host' - & twsConnection . port .~ T.pack port' + & twsConnection . host .~ host' + & twsConnection . port .~ port' liftIO $ encodeFile "settings.json" settings' logInfo $ display ("Settings Saved" :: Text) -- save cached data - logInfo $ display $ T.pack $ ppShow settings' + logInfo $ display $ ppShow' settings' renderLoop :: RIO App () renderLoop = do @@ -87,9 +87,9 @@ renderLoop = do True -> shutdownApp let cr = twsConnectionRefs refs' accs <- fmap HM.keys $ liftIO $ readTVarIO $ Types.accounts data' - withComboOpen "Account" (maybe "Select account" T.unpack selectedAccount) $ do + withComboOpen "Account" (fromMaybe "Select account" selectedAccount) $ do forM_ accs $ \a -> do - selectable (T.unpack a) >>= \case + selectable a >>= \case False -> return () True -> do -- cancel subscription of old account (if any) @@ -108,13 +108,13 @@ renderLoop = do False -> return () True -> do if connStatus == TWSDisconnected then do - logDebug $ display ("Connecting to TWS on " <> T.pack connHost <> ":" <> T.pack connPort <> "." :: Text) + logDebug $ display ("Connecting to TWS on " <> connHost <> ":" <> connPort <> "." :: Text) app <- ask void $ liftIO $ forkIO $ forkClient app else do logInfo $ display ("Tried to connect, but we are connected" :: Text) return () - cStatusText <- liftIO $ get (InjetiveGettable cStatus :: InjetiveGettable TWSConnectionStatus String) + cStatusText <- liftIO $ get (InjetiveGettable cStatus :: InjetiveGettable TWSConnectionStatus Text) textColored (InjetiveGettable cStatus :: InjetiveGettable TWSConnectionStatus ImVec4) cStatusText @@ -132,14 +132,14 @@ renderLoop = do connHost <- liftIO $ readTVarIO cHost connPort <- liftIO $ readTVarIO cPort if connStatus == TWSDisconnected then do - logDebug $ display ("Connecting to TWS on " <> T.pack connHost <> ":" <> T.pack connPort <> "." :: Text) + logDebug $ display ("Connecting to TWS on " <> connHost <> ":" <> connPort <> "." :: Text) app <- ask void $ liftIO $ forkIO $ forkClient app else do logInfo $ display ("Tried to connect, but we are connected" :: Text) return () -- TODO: show connection-status - cStatusText <- liftIO $ get (InjetiveGettable cStatus :: InjetiveGettable TWSConnectionStatus String) + cStatusText <- liftIO $ get (InjetiveGettable cStatus :: InjetiveGettable TWSConnectionStatus Text) textColored (InjetiveGettable cStatus :: InjetiveGettable TWSConnectionStatus ImVec4) cStatusText bracket_ (begin "Portfolio") end $ do @@ -160,12 +160,12 @@ renderLoop = do forM_ ((accs HM.! aid) ^.. accountPortfolio . traverse) $ \(IBPortfolioValue c p mp mv ac up rp) -> do tableNextRow - tableNextColumn $ text $ T.unpack $ localSymbol c - tableNextColumn $ text $ show p - tableNextColumn $ text $ show up - tableNextColumn $ text $ show rp - tableNextColumn $ text $ show mp - tableNextColumn $ text $ show mv + tableNextColumn $ text $ localSymbol c + tableNextColumn $ text $ fromString $ show p + tableNextColumn $ text $ fromString $ show up + tableNextColumn $ text $ fromString $ show rp + tableNextColumn $ text $ fromString $ show mp + tableNextColumn $ text $ fromString $ show mv bracket_ (begin "Search Symbols") end $ do readTVarIO (currentAccount refs') >>= \case @@ -176,7 +176,7 @@ renderLoop = do readTVarIO nextIDVar >>= \case Nothing -> text "no id available, waiting ..." Just i -> do - void $ inputText "Symbol-Lookup" (InjetiveGettable @Text @String sLookup) 255 + void $ inputText "Symbol-Lookup" (InjetiveGettable @Text @Text sLookup) 255 button "Lookup" >>= \case False -> return () True -> @@ -196,7 +196,7 @@ renderLoop = do tableHeadersRow lResult <- readTVarIO $ symbolLookupResults data' forM_ lResult $ \contract@IBSymbolSample{..} -> do - let popupName = "SymbolAction"<>show _symbolId + let popupName = fromString $ "SymbolAction"<>show _symbolId withPopup popupName $ \isPopupOpen -> do when isPopupOpen $ do button "creatChart" >>= \case @@ -204,10 +204,10 @@ renderLoop = do True -> do logInfo $ display $ "new chart open for: " <> _symbol newChart $ def { conId = _symbolId, symbol = _symbol, secType = _secType, exchange = "SMART", primaryExchange = _primaryExchange, currency = _currency} - let printDatum x = tableNextColumn $ text $ T.unpack x + let printDatum x = tableNextColumn $ text $ x tableNextRow tableNextColumn $ do - void $ selectableWith (defSelectableOptions { flags = ImGuiSelectableFlags_SpanAllColumns }) (T.unpack _symbol) + void $ selectableWith (defSelectableOptions { flags = ImGuiSelectableFlags_SpanAllColumns }) _symbol openPopupOnItemClick popupName ImGuiPopupFlags_MouseButtonRight printDatum _secType printDatum _primaryExchange @@ -217,13 +217,13 @@ renderLoop = do -- chart windows charts <- liftIO . readTVarIO . appCharts $ refs' forM_ (HM.toList charts) $ \(symbol, cVar) -> do - bracket_ (begin (T.unpack symbol)) end $ do + bracket_ (begin symbol) end $ do Chart{..} <- liftIO . readTVarIO $ cVar case viewr chartData of EmptyR -> text "no last price" - (_ :> ChartPoint{..}) -> text $ "Last: " <> show pointValue <> "\nTime: " <> show timeOfDay - text $ ppShow chartCache - text $ ppShow lastCacheUpdate + (_ :> ChartPoint{..}) -> text $ fromString $ "Last: " <> show pointValue <> "\nTime: " <> show timeOfDay + text $ ppShow' chartCache + text $ ppShow' lastCacheUpdate return () diff --git a/src/Types.hs b/src/Types.hs index 348dc29..151a96c 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -33,8 +33,8 @@ data Options = Options } data WindowParams = WindowParams - { _windowHeight :: Int - , _windowWidth :: Int + { _windowWidth :: Int + , _windowHeight :: Int } deriving (Show, Generic, FromJSON, ToJSON) instance Default WindowParams where @@ -82,8 +82,8 @@ data TWSConnectionStatus = TWSDisconnected deriving (Show, Eq, Enum, Bounded) data TWSConnectionRefs = TWSConnectionRefs - { twsConnectionRefsHost :: TVar String - , twsConnectionRefsPort :: TVar String + { twsConnectionRefsHost :: TVar Text + , twsConnectionRefsPort :: TVar Text , twsConnectionStatus :: TVar TWSConnectionStatus , twsConnectionSend :: TQueue Msg_IB_OUT , twsConnectionRecieve :: TQueue Msg_IB_IN @@ -95,7 +95,7 @@ instance Injective TWSConnectionStatus ImVec4 where TWSConnecting -> ImVec4 1 1 0 1 TWSConnected -> ImVec4 0 1 0 1 -instance Injective TWSConnectionStatus String where +instance Injective TWSConnectionStatus Text where to = \case TWSDisconnected -> "Not Connected" TWSConnecting -> "Trying to connect..."