From 80b5f09d95d0fc3f00fa9d01e7d5cbcfbf6d3450 Mon Sep 17 00:00:00 2001 From: Stefan Dresselhaus Date: Mon, 18 Jul 2022 17:50:28 +0200 Subject: [PATCH] current state --- .gitignore | 1 + app/Main.hs | 99 +++++++++++++------------- cabal.project | 7 ++ deps/dear-imgui.hs | 2 +- deps/dear-implot.hs | 2 +- ibhelper.cabal | 166 ++++++++++---------------------------------- package.yaml | 12 +++- src/Chart.hs | 2 +- src/Run.hs | 80 ++++++++++++--------- src/Types.hs | 2 +- stack.yaml | 8 ++- 11 files changed, 158 insertions(+), 223 deletions(-) create mode 100644 cabal.project mode change 160000 => 120000 deps/dear-imgui.hs diff --git a/.gitignore b/.gitignore index aed424b..9927b64 100644 --- a/.gitignore +++ b/.gitignore @@ -6,3 +6,4 @@ imgui.ini settings.json *.lock tags +dist-newstyle/ diff --git a/app/Main.hs b/app/Main.hs index ac2a3a7..12a152d 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -7,18 +7,19 @@ import Data.Aeson (eitherDecodeFileStrict') import Control.Monad.Managed import Control.Concurrent import DearImGui +import DearImGui.Plot import DearImGui.OpenGL3 -import DearImGui.GLFW -import DearImGui.GLFW.OpenGL +import DearImGui.SDL +import DearImGui.SDL.OpenGL import Run import RIO.Process import System.Directory import Options.Applicative.Simple import qualified Paths_ibhelper -import qualified Graphics.UI.GLFW as GLFW import qualified Data.Text as T import Prelude (putStrLn) import AppFiller +import SDL main :: IO () @@ -50,59 +51,55 @@ main = do withLogFunc lo $ \lf -> do -- let bare_log = unLogFunc $ view logFuncL lf -- logErr = liftIO . bare_log callStack "" LevelError - initialized <- GLFW.init - unless initialized $ error "GLFW init failed" + initializeAll liftIO $ runManaged $ do - mwin <- managed $ bracket - (GLFW.createWindow (settings ^. windowParams . windowWidth) (settings ^. windowParams . windowHeight) "IB-Helper" Nothing Nothing) - (maybe (return ()) GLFW.destroyWindow) - case mwin of - Just win -> do - liftIO $ do - GLFW.makeContextCurrent (Just win) - GLFW.swapInterval 1 + win <- do + let title = "IB-Helper" + let config = defaultWindow { windowGraphicsContext = OpenGLContext defaultOpenGL + , windowInitialSize = V2 (settings ^. windowParams . windowWidth . to fromIntegral) (settings ^. windowParams . windowHeight . to fromIntegral) + , windowResizable = True + } + managed $ bracket (createWindow title config) destroyWindow - -- Create an ImGui context - _ <- managed $ bracket createContext destroyContext + -- Create OpenGL Context + glContext <- managed $ bracket (glCreateContext win) glDeleteContext - -- Create an ImPlot context - -- _ <- managed $ bracket createPlotContext destroyPlotContext + -- Create an ImGui context + _ <- managed $ bracket createContext destroyContext - -- Initialize ImGui's GLFW backend - _ <- managed_ $ bracket_ (glfwInitForOpenGL win True) glfwShutdown + -- Create an ImPlot context + _ <- managed $ bracket createPlotContext destroyPlotContext - -- Initialize ImGui's OpenGL backend - _ <- managed_ $ bracket_ openGL3Init openGL3Shutdown + -- Initialize ImGui's SDL2 backend + _ <- managed_ $ bracket_ (sdl2InitForOpenGL win glContext) sdl2Shutdown - twsConnectionRefsHost <- liftIO $ atomically $ newTVar $ settings ^. twsConnection . host . to T.unpack - twsConnectionRefsPort <- liftIO $ atomically $ newTVar $ settings ^. twsConnection . port . to T.unpack - twsConnectionStatus <- liftIO $ atomically $ newTVar $ TWSDisconnected - twsConnectionSend <- liftIO $ atomically $ newTQueue - twsConnectionRecieve <- liftIO $ atomically $ newTQueue - let twsConnectionRefs = TWSConnectionRefs{..} - liftIO $ atomically $ writeTQueue twsConnectionSend $ Msg_IB_OUT $ IB_RequestMarketDataType DelayedFrozen - currentAccount <- liftIO $ newTVarIO $ Nothing - tickerIdToSymbol <- liftIO $ newTVarIO $ mempty - appCharts <- liftIO $ newTVarIO $ mempty - appData <- liftIO $ DataRefs - <$> newTVarIO mempty - <*> newTVarIO Nothing - <*> newTVarIO mempty - <*> newTVarIO mempty - let app = App - { appSettings = settings - , appLogFunc = lf - , appProcessContext = pc - , appOptions = options - , appWindow = win - , appRefs = AppRefs{..} - , appData = appData - } - void $ liftIO $ forkIO $ appFiller app - liftIO $ runRIO app run - Nothing -> do - error "GLFW createWindow failed" - - GLFW.terminate + -- 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 + twsConnectionStatus <- liftIO $ atomically $ newTVar $ TWSDisconnected + twsConnectionSend <- liftIO $ atomically $ newTQueue + twsConnectionRecieve <- liftIO $ atomically $ newTQueue + let twsConnectionRefs = TWSConnectionRefs{..} + liftIO $ atomically $ writeTQueue twsConnectionSend $ Msg_IB_OUT $ IB_RequestMarketDataType DelayedFrozen + currentAccount <- liftIO $ newTVarIO $ Nothing + tickerIdToSymbol <- liftIO $ newTVarIO $ mempty + appCharts <- liftIO $ newTVarIO $ mempty + appData <- liftIO $ DataRefs + <$> newTVarIO mempty + <*> newTVarIO Nothing + <*> newTVarIO mempty + <*> newTVarIO mempty + let app = App + { appSettings = settings + , appLogFunc = lf + , appProcessContext = pc + , appOptions = options + , appWindow = win + , appRefs = AppRefs{..} + , appData = appData + } + void $ liftIO $ forkIO $ appFiller app + liftIO $ runRIO app run diff --git a/cabal.project b/cabal.project new file mode 100644 index 0000000..16ecf02 --- /dev/null +++ b/cabal.project @@ -0,0 +1,7 @@ +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 diff --git a/deps/dear-imgui.hs b/deps/dear-imgui.hs deleted file mode 160000 index e5969f6..0000000 --- a/deps/dear-imgui.hs +++ /dev/null @@ -1 +0,0 @@ -Subproject commit e5969f6b358dab01d9e2bea8d3538fdfbee0c2f1 diff --git a/deps/dear-imgui.hs b/deps/dear-imgui.hs new file mode 120000 index 0000000..c28e2bd --- /dev/null +++ b/deps/dear-imgui.hs @@ -0,0 +1 @@ +dear-implot.hs/dear-imgui.hs/ \ No newline at end of file diff --git a/deps/dear-implot.hs b/deps/dear-implot.hs index 78f7df0..9a62697 160000 --- a/deps/dear-implot.hs +++ b/deps/dear-implot.hs @@ -1 +1 @@ -Subproject commit 78f7df091ceb88f57eaacdb0a1e2d43cbce04566 +Subproject commit 9a62697e8d50aae80536b6c4dbe6cef67062a71d diff --git a/ibhelper.cabal b/ibhelper.cabal index 7a138fd..071f1fc 100644 --- a/ibhelper.cabal +++ b/ibhelper.cabal @@ -1,9 +1,10 @@ -cabal-version: 1.12 - --- This file has been generated from package.yaml by hpack version 0.34.4. +-- This file has been generated from package.yaml by hpack version 0.27.0. -- -- see: https://github.com/sol/hpack +-- +-- hash: db89b15a8762e7924ae32ea1dcce94b46e75d067b37cc058d3be20c1e0b98964 +cabal-version: >= 1.10 name: ibhelper version: 0.1.0.0 description: Please see the README.md @@ -15,9 +16,10 @@ copyright: 2022 Stefan Dresselhaus license: BSD3 license-file: LICENSE build-type: Simple + extra-source-files: - README.md ChangeLog.md + README.md source-repository head type: git @@ -37,55 +39,22 @@ library Paths_ibhelper hs-source-dirs: src - default-extensions: - BangPatterns - BinaryLiterals - ConstraintKinds - DataKinds - DefaultSignatures - DeriveDataTypeable - DeriveFoldable - DeriveFunctor - DeriveGeneric - DeriveTraversable - DoAndIfThenElse - EmptyDataDecls - ExistentialQuantification - FlexibleContexts - FlexibleInstances - FunctionalDependencies - GADTs - GeneralizedNewtypeDeriving - InstanceSigs - KindSignatures - LambdaCase - MultiParamTypeClasses - MultiWayIf - NamedFieldPuns - NoImplicitPrelude - OverloadedStrings - PartialTypeSignatures - PatternGuards - PolyKinds - RankNTypes - RecordWildCards - ScopedTypeVariables - StandaloneDeriving - TupleSections - TypeFamilies - TypeSynonymInstances - ViewPatterns - DuplicateRecordFields + default-extensions: BangPatterns BinaryLiterals ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DoAndIfThenElse EmptyDataDecls ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PartialTypeSignatures PatternGuards PolyKinds RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TupleSections TypeFamilies TypeSynonymInstances ViewPatterns DuplicateRecordFields ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints + include-dirs: + deps/dear-implot.hs/implot + deps/dear-imgui.hs/imgui + extra-libraries: + HSdear-imgui-1.4.0-inplace build-depends: - GLFW-b - , StateVar + StateVar , aeson , base >=4.11 && <10 , binary , bytestring , data-default - , dear-imgui + , dear-imgui >=1.4.0 + , dear-implot , directory , fingertree , gl @@ -94,6 +63,7 @@ library , network , pretty-show , rio >=0.1.12.0 + , sdl2 , stm , text , time @@ -107,55 +77,22 @@ executable ibhelper-exe Paths_ibhelper hs-source-dirs: app - default-extensions: - BangPatterns - BinaryLiterals - ConstraintKinds - DataKinds - DefaultSignatures - DeriveDataTypeable - DeriveFoldable - DeriveFunctor - DeriveGeneric - DeriveTraversable - DoAndIfThenElse - EmptyDataDecls - ExistentialQuantification - FlexibleContexts - FlexibleInstances - FunctionalDependencies - GADTs - GeneralizedNewtypeDeriving - InstanceSigs - KindSignatures - LambdaCase - MultiParamTypeClasses - MultiWayIf - NamedFieldPuns - NoImplicitPrelude - OverloadedStrings - PartialTypeSignatures - PatternGuards - PolyKinds - RankNTypes - RecordWildCards - ScopedTypeVariables - StandaloneDeriving - TupleSections - TypeFamilies - TypeSynonymInstances - ViewPatterns - DuplicateRecordFields + default-extensions: BangPatterns BinaryLiterals ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DoAndIfThenElse EmptyDataDecls ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PartialTypeSignatures PatternGuards PolyKinds RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TupleSections TypeFamilies TypeSynonymInstances ViewPatterns DuplicateRecordFields ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N + include-dirs: + deps/dear-implot.hs/implot + deps/dear-imgui.hs/imgui + extra-libraries: + HSdear-imgui-1.4.0-inplace build-depends: - GLFW-b - , StateVar + StateVar , aeson , base >=4.11 && <10 , binary , bytestring , data-default - , dear-imgui + , dear-imgui >=1.4.0 + , dear-implot , directory , fingertree , gl @@ -166,6 +103,7 @@ executable ibhelper-exe , optparse-simple , pretty-show , rio >=0.1.12.0 + , sdl2 , stm , text , time @@ -181,55 +119,22 @@ test-suite ibhelper-test Paths_ibhelper hs-source-dirs: test - default-extensions: - BangPatterns - BinaryLiterals - ConstraintKinds - DataKinds - DefaultSignatures - DeriveDataTypeable - DeriveFoldable - DeriveFunctor - DeriveGeneric - DeriveTraversable - DoAndIfThenElse - EmptyDataDecls - ExistentialQuantification - FlexibleContexts - FlexibleInstances - FunctionalDependencies - GADTs - GeneralizedNewtypeDeriving - InstanceSigs - KindSignatures - LambdaCase - MultiParamTypeClasses - MultiWayIf - NamedFieldPuns - NoImplicitPrelude - OverloadedStrings - PartialTypeSignatures - PatternGuards - PolyKinds - RankNTypes - RecordWildCards - ScopedTypeVariables - StandaloneDeriving - TupleSections - TypeFamilies - TypeSynonymInstances - ViewPatterns - DuplicateRecordFields + default-extensions: BangPatterns BinaryLiterals ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DoAndIfThenElse EmptyDataDecls ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PartialTypeSignatures PatternGuards PolyKinds RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TupleSections TypeFamilies TypeSynonymInstances ViewPatterns DuplicateRecordFields ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N + include-dirs: + deps/dear-implot.hs/implot + deps/dear-imgui.hs/imgui + extra-libraries: + HSdear-imgui-1.4.0-inplace build-depends: - GLFW-b - , StateVar + StateVar , aeson , base >=4.11 && <10 , binary , bytestring , data-default - , dear-imgui + , dear-imgui >=1.4.0 + , dear-implot , directory , fingertree , gl @@ -240,6 +145,7 @@ test-suite ibhelper-test , network , pretty-show , rio >=0.1.12.0 + , sdl2 , stm , text , time diff --git a/package.yaml b/package.yaml index ba96f63..3e951dc 100644 --- a/package.yaml +++ b/package.yaml @@ -19,6 +19,13 @@ extra-source-files: # common to point users to the README.md file. description: Please see the README.md +include-dirs: + - deps/dear-implot.hs/implot + - deps/dear-imgui.hs/imgui + +extra-libraries: + - HSdear-imgui-1.4.0-inplace + default-extensions: - BangPatterns - BinaryLiterals @@ -62,8 +69,7 @@ default-extensions: dependencies: - base >= 4.11 && < 10 - rio >= 0.1.12.0 -- dear-imgui -- GLFW-b +- dear-imgui >= 1.4.0 - managed - gl - aeson @@ -81,6 +87,8 @@ dependencies: - time - unordered-containers - fingertree +- dear-implot +- sdl2 ghc-options: - -Wall diff --git a/src/Chart.hs b/src/Chart.hs index 670c45a..795420a 100644 --- a/src/Chart.hs +++ b/src/Chart.hs @@ -22,7 +22,7 @@ data FillerException = QuitFiller instance Exception FillerException -deriving via Integer instance Hashable Day +--deriving via Integer instance Hashable Day newChart :: IBContract -> RIO App () newChart contract = do diff --git a/src/Run.hs b/src/Run.hs index 56e801a..6e0b675 100644 --- a/src/Run.hs +++ b/src/Run.hs @@ -11,11 +11,12 @@ import Data.Aeson (encodeFile) import Data.Bits import Data.FingerTree (ViewL(..), ViewR(..), viewl, viewr, split, FingerTree) import DearImGui +import DearImGui.Plot import DearImGui.OpenGL3 -import DearImGui.GLFW +import DearImGui.SDL import Graphics.GL +import SDL import Data.StateVar -import qualified Graphics.UI.GLFW as GLFW import qualified Data.Text as T import qualified Data.HashMap.Strict as HM import qualified Data.FingerTree as FT @@ -30,29 +31,42 @@ run = do -- close connections to IB +shutdownApp :: RIO App () +shutdownApp = do + win <- appWindow <$> ask + -- save settings & config + (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' + liftIO $ encodeFile "settings.json" settings' + logInfo $ display ("Settings Saved" :: Text) + -- save cached data + + logInfo $ display $ T.pack $ ppShow settings' + renderLoop :: RIO App () renderLoop = do win <- appWindow <$> ask - liftIO GLFW.pollEvents - close <- liftIO $ GLFW.windowShouldClose win + let checkEvents = do + pollEventWithImGui >>= \case + Nothing -> + return False + Just event -> + (isQuit event ||) <$> checkEvents + + isQuit event = + SDL.eventPayload event == SDL.QuitEvent + + close <- liftIO checkEvents if close - then do - -- save settings & config - (w,h) <- liftIO $ GLFW.getWindowSize win - settings <- appSettings <$> ask - refs <- appRefs <$> ask - host' <- liftIO . readTVarIO . twsConnectionRefsHost . twsConnectionRefs $ refs - port' <- liftIO . readTVarIO . twsConnectionRefsPort . twsConnectionRefs $ refs - let settings' = settings & windowParams . windowWidth .~ w - & windowParams . windowHeight .~ h - & twsConnection . host .~ T.pack host' - & twsConnection . port .~ T.pack port' - liftIO $ encodeFile "settings.json" settings' - logInfo $ display ("Settings Saved" :: Text) - -- save cached data - - logInfo $ display $ T.pack $ ppShow settings' + then shutdownApp else do refs' <- appRefs <$> ask data' <- appData <$> ask @@ -61,7 +75,7 @@ renderLoop = do -- Tell ImGui we're starting a new frame liftIO $ do openGL3NewFrame - glfwNewFrame + sdl2NewFrame newFrame @@ -70,7 +84,7 @@ renderLoop = do withMenuOpen "File" $ do menuItem "Quit" >>= \case False -> return () - True -> liftIO $ GLFW.setWindowShouldClose win True + True -> shutdownApp let cr = twsConnectionRefs refs' accs <- fmap HM.keys $ liftIO $ readTVarIO $ Types.accounts data' withComboOpen "Account" (maybe "Select account" T.unpack selectedAccount) $ do @@ -146,12 +160,12 @@ renderLoop = do forM_ ((accs HM.! aid) ^.. accountPortfolio . traverse) $ \(IBPortfolioValue c p mp mv ac up rp) -> do tableNextRow - whenM tableNextColumn (text $ T.unpack $ localSymbol c) - whenM tableNextColumn (text $ show p) - whenM tableNextColumn (text $ show up) - whenM tableNextColumn (text $ show rp) - whenM tableNextColumn (text $ show mp) - whenM tableNextColumn (text $ show mv) + 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 bracket_ (begin "Search Symbols") end $ do readTVarIO (currentAccount refs') >>= \case @@ -177,7 +191,7 @@ renderLoop = do tableSetupColumn "Primary exchange" tableSetupColumn "Currency" tableSetupColumn "Available derivatives" - withSortableTable $ \(mustSort, sortSpecs) -> do + withSortableTable $ \mustSort sortSpecs -> do when mustSort $ liftIO $ pPrint sortSpecs tableHeadersRow lResult <- readTVarIO $ symbolLookupResults data' @@ -190,9 +204,9 @@ 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 = whenM tableNextColumn $ text $ T.unpack x + let printDatum x = tableNextColumn $ text $ T.unpack x tableNextRow - whenM tableNextColumn $ do + tableNextColumn $ do void $ selectableWith (defSelectableOptions { flags = ImGuiSelectableFlags_SpanAllColumns }) (T.unpack _symbol) openPopupOnItemClick popupName ImGuiPopupFlags_MouseButtonRight printDatum _secType @@ -217,7 +231,7 @@ renderLoop = do showDemoWindow -- Show the ImPlot demo window - --showPlotDemoWindow + showPlotDemoWindow -- Render liftIO $ glClear GL_COLOR_BUFFER_BIT @@ -225,6 +239,6 @@ renderLoop = do render liftIO $ openGL3RenderDrawData =<< getDrawData - liftIO $ GLFW.swapBuffers win + liftIO $ glSwapWindow win renderLoop diff --git a/src/Types.hs b/src/Types.hs index 1abe00a..348dc29 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -18,7 +18,7 @@ import Data.Time import Data.FingerTree import Data.Semigroup import GHC.Generics -import Graphics.UI.GLFW (Window) +import SDL (Window) import DearImGui import RIO import RIO.Process diff --git a/stack.yaml b/stack.yaml index fedace7..04209a1 100644 --- a/stack.yaml +++ b/stack.yaml @@ -31,6 +31,7 @@ resolver: lts-18.24 packages: - . - deps/dear-imgui.hs +- deps/dear-implot.hs # Dependency packages to be pulled from upstream that are not in the resolver. # These entries can reference officially published versions as well as # forks / in-progress versions pinned to a git hash. For example: @@ -50,8 +51,8 @@ allow-newer: true flags: dear-imgui: # libraries - glfw: true - sdl: false + glfw: false + sdl: true vulkan: false # hardware-requirements opengl3: true @@ -73,7 +74,8 @@ flags: # # Extra directories used by stack for building # extra-include-dirs: [/path/to/dir] -# extra-lib-dirs: [/path/to/dir] +extra-lib-dirs: + - deps/dear-imgui.hs/build/ # # Allow a newer minor version of GHC than the snapshot specifies # compiler-check: newer-minor