Drezil/ibhelper
1
1
Fork 0
Code Issues 12 Pull Requests Projects Releases Wiki Activity

compiles and works again.

Browse Source
This commit is contained in:
Nicole Dresselhaus 2022-07-19 23:07:01 +02:00
parent 9e9fa9e512
commit 980c309281
9 changed files with 58 additions and 45 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
app/Main.hs
View File

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

8
cabal.project
View File

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

2
deps/dear-implot.hs vendored

@ -1 +1 @@
Subproject commit c06c3d266587545240b4fde6e33bcc67d16a871a
Subproject commit c6a30057c3059ec7b579fc00c3da21a2bc1a35f7

19
ibhelper.cabal
View File

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

2
package.yaml
View File

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

2
src/IBClient/Connection.hs
View File

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

8
src/Import.hs
View File

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

46
src/Run.hs
View File

@ -42,13 +42,13 @@ shutdownApp = do
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 ()

10
src/Types.hs
View File

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