current state

This commit is contained in:
Nicole Dresselhaus 2022-07-18 17:50:28 +02:00
parent befb1ab1eb
commit 80b5f09d95
Signed by: Drezil
GPG Key ID: AC88BB432537313A
11 changed files with 158 additions and 223 deletions

1
.gitignore vendored
View File

@ -6,3 +6,4 @@ imgui.ini
settings.json
*.lock
tags
dist-newstyle/

View File

@ -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

7
cabal.project Normal file
View File

@ -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

1
deps/dear-imgui.hs vendored

@ -1 +0,0 @@
Subproject commit e5969f6b358dab01d9e2bea8d3538fdfbee0c2f1

1
deps/dear-imgui.hs vendored Symbolic link
View File

@ -0,0 +1 @@
dear-implot.hs/dear-imgui.hs/

2
deps/dear-implot.hs vendored

@ -1 +1 @@
Subproject commit 78f7df091ceb88f57eaacdb0a1e2d43cbce04566
Subproject commit 9a62697e8d50aae80536b6c4dbe6cef67062a71d

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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