Init
This commit is contained in:
commit
befb1ab1eb
GPG Key ID:
AC88BB432537313A
8
.gitignore
vendored
Normal file
8
.gitignore
vendored
Normal file
@ -0,0 +1,8 @@
|
||||
*~
|
||||
*.swp
|
||||
tarballs/
|
||||
.stack-work/
|
||||
imgui.ini
|
||||
settings.json
|
||||
*.lock
|
||||
tags
|
||||
6
.gitmodules
vendored
Normal file
6
.gitmodules
vendored
Normal file
@ -0,0 +1,6 @@
|
||||
[submodule "deps/dear-implot.hs"]
|
||||
path = deps/dear-implot.hs
|
||||
url = https://github.com/Drezil/dear-implot.hs
|
||||
[submodule "deps/dear-imgui.hs"]
|
||||
path = deps/dear-imgui.hs
|
||||
url = https://github.com/haskell-game/dear-imgui.hs
|
||||
0
.hlint.yaml
Normal file
0
.hlint.yaml
Normal file
3
ChangeLog.md
Normal file
3
ChangeLog.md
Normal file
@ -0,0 +1,3 @@
|
||||
# Changelog for ibhelper
|
||||
|
||||
## Unreleased changes
|
||||
30
LICENSE
Normal file
30
LICENSE
Normal file
@ -0,0 +1,30 @@
|
||||
Copyright Stefan Dresselhaus (c) 2019
|
||||
|
||||
All rights reserved.
|
||||
|
||||
Redistribution and use in source and binary forms, with or without
|
||||
modification, are permitted provided that the following conditions are met:
|
||||
|
||||
* Redistributions of source code must retain the above copyright
|
||||
notice, this list of conditions and the following disclaimer.
|
||||
|
||||
* Redistributions in binary form must reproduce the above
|
||||
copyright notice, this list of conditions and the following
|
||||
disclaimer in the documentation and/or other materials provided
|
||||
with the distribution.
|
||||
|
||||
* Neither the name of Author name here nor the names of other
|
||||
contributors may be used to endorse or promote products derived
|
||||
from this software without specific prior written permission.
|
||||
|
||||
THIS SOFTWARE IS PROVIDED BY THE 2022 Stefan Dresselhaus HOLDERS AND CONTRIBUTORS
|
||||
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
|
||||
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
|
||||
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 2022 Stefan Dresselhaus
|
||||
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
|
||||
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
|
||||
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
|
||||
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
|
||||
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
|
||||
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
|
||||
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
10
README.md
Normal file
10
README.md
Normal file
@ -0,0 +1,10 @@
|
||||
# ibhelper
|
||||
|
||||
## Execute
|
||||
|
||||
* Run `stack exec -- ibhelper-exe` to see "We're inside the application!"
|
||||
* With `stack exec -- ibhelper-exe --verbose` you will see the same message, with more logging.
|
||||
|
||||
## Run tests
|
||||
|
||||
`stack test`
|
||||
108
app/Main.hs
Normal file
108
app/Main.hs
Normal file
@ -0,0 +1,108 @@
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
module Main (main) where
|
||||
|
||||
import Import
|
||||
import Data.Aeson (eitherDecodeFileStrict')
|
||||
import Control.Monad.Managed
|
||||
import Control.Concurrent
|
||||
import DearImGui
|
||||
import DearImGui.OpenGL3
|
||||
import DearImGui.GLFW
|
||||
import DearImGui.GLFW.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
|
||||
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
(options, ()) <- simpleOptions
|
||||
$(simpleVersion Paths_ibhelper.version)
|
||||
"Header for command line arguments"
|
||||
"Program description, also for command line arguments"
|
||||
(Options
|
||||
<$> switch ( long "verbose"
|
||||
<> short 'v'
|
||||
<> help "Verbose output?"
|
||||
)
|
||||
)
|
||||
empty
|
||||
settingsFileExists <- doesFileExist "settings.json"
|
||||
settings <- if settingsFileExists
|
||||
then do
|
||||
s <- fmap unDefaultJSON <$> eitherDecodeFileStrict' "settings.json"
|
||||
pPrint s
|
||||
case s of
|
||||
Left e -> putStrLn ("Error loading settings: \n"<>e) >> return def
|
||||
Right s' -> return s'
|
||||
else return def
|
||||
lo <- logOptionsHandle stderr (optionsVerbose options)
|
||||
<&> setLogMinLevel (settings ^. logLevel)
|
||||
<&> setLogTerminal True
|
||||
pc <- mkDefaultProcessContext
|
||||
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"
|
||||
|
||||
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
|
||||
|
||||
-- Create an ImGui context
|
||||
_ <- managed $ bracket createContext destroyContext
|
||||
|
||||
-- Create an ImPlot context
|
||||
-- _ <- managed $ bracket createPlotContext destroyPlotContext
|
||||
|
||||
-- Initialize ImGui's GLFW backend
|
||||
_ <- managed_ $ bracket_ (glfwInitForOpenGL win True) glfwShutdown
|
||||
|
||||
-- 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
|
||||
Nothing -> do
|
||||
error "GLFW createWindow failed"
|
||||
|
||||
GLFW.terminate
|
||||
|
||||
1
deps/dear-imgui.hs
vendored
Submodule
1
deps/dear-imgui.hs
vendored
Submodule
@ -0,0 +1 @@
|
||||
Subproject commit e5969f6b358dab01d9e2bea8d3538fdfbee0c2f1
|
||||
1
deps/dear-implot.hs
vendored
Submodule
1
deps/dear-implot.hs
vendored
Submodule
@ -0,0 +1 @@
|
||||
Subproject commit 78f7df091ceb88f57eaacdb0a1e2d43cbce04566
|
||||
248
ibhelper.cabal
Normal file
248
ibhelper.cabal
Normal file
@ -0,0 +1,248 @@
|
||||
cabal-version: 1.12
|
||||
|
||||
-- This file has been generated from package.yaml by hpack version 0.34.4.
|
||||
--
|
||||
-- see: https://github.com/sol/hpack
|
||||
|
||||
name: ibhelper
|
||||
version: 0.1.0.0
|
||||
description: Please see the README.md
|
||||
homepage: https://github.com/Drezil/ibhelper#readme
|
||||
bug-reports: https://github.com/Drezil/ibhelper/issues
|
||||
author: Stefan Dresselhaus
|
||||
maintainer: sdressel@pwning.de
|
||||
copyright: 2022 Stefan Dresselhaus
|
||||
license: BSD3
|
||||
license-file: LICENSE
|
||||
build-type: Simple
|
||||
extra-source-files:
|
||||
README.md
|
||||
ChangeLog.md
|
||||
|
||||
source-repository head
|
||||
type: git
|
||||
location: https://github.com/Drezil/ibhelper
|
||||
|
||||
library
|
||||
exposed-modules:
|
||||
AppFiller
|
||||
Chart
|
||||
IBClient.Connection
|
||||
IBClient.Types
|
||||
Import
|
||||
Run
|
||||
Types
|
||||
Util
|
||||
other-modules:
|
||||
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
|
||||
ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints
|
||||
build-depends:
|
||||
GLFW-b
|
||||
, StateVar
|
||||
, aeson
|
||||
, base >=4.11 && <10
|
||||
, binary
|
||||
, bytestring
|
||||
, data-default
|
||||
, dear-imgui
|
||||
, directory
|
||||
, fingertree
|
||||
, gl
|
||||
, managed
|
||||
, microlens-th
|
||||
, network
|
||||
, pretty-show
|
||||
, rio >=0.1.12.0
|
||||
, stm
|
||||
, text
|
||||
, time
|
||||
, type-iso
|
||||
, unordered-containers
|
||||
default-language: Haskell2010
|
||||
|
||||
executable ibhelper-exe
|
||||
main-is: Main.hs
|
||||
other-modules:
|
||||
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
|
||||
ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N
|
||||
build-depends:
|
||||
GLFW-b
|
||||
, StateVar
|
||||
, aeson
|
||||
, base >=4.11 && <10
|
||||
, binary
|
||||
, bytestring
|
||||
, data-default
|
||||
, dear-imgui
|
||||
, directory
|
||||
, fingertree
|
||||
, gl
|
||||
, ibhelper
|
||||
, managed
|
||||
, microlens-th
|
||||
, network
|
||||
, optparse-simple
|
||||
, pretty-show
|
||||
, rio >=0.1.12.0
|
||||
, stm
|
||||
, text
|
||||
, time
|
||||
, type-iso
|
||||
, unordered-containers
|
||||
default-language: Haskell2010
|
||||
|
||||
test-suite ibhelper-test
|
||||
type: exitcode-stdio-1.0
|
||||
main-is: Spec.hs
|
||||
other-modules:
|
||||
UtilSpec
|
||||
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
|
||||
ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N
|
||||
build-depends:
|
||||
GLFW-b
|
||||
, StateVar
|
||||
, aeson
|
||||
, base >=4.11 && <10
|
||||
, binary
|
||||
, bytestring
|
||||
, data-default
|
||||
, dear-imgui
|
||||
, directory
|
||||
, fingertree
|
||||
, gl
|
||||
, hspec
|
||||
, ibhelper
|
||||
, managed
|
||||
, microlens-th
|
||||
, network
|
||||
, pretty-show
|
||||
, rio >=0.1.12.0
|
||||
, stm
|
||||
, text
|
||||
, time
|
||||
, type-iso
|
||||
, unordered-containers
|
||||
default-language: Haskell2010
|
||||
121
package.yaml
Normal file
121
package.yaml
Normal file
@ -0,0 +1,121 @@
|
||||
name: ibhelper
|
||||
version: 0.1.0.0
|
||||
github: Drezil/ibhelper
|
||||
license: BSD3
|
||||
author: Stefan Dresselhaus
|
||||
maintainer: sdressel@pwning.de
|
||||
copyright: 2022 Stefan Dresselhaus
|
||||
|
||||
extra-source-files:
|
||||
- README.md
|
||||
- ChangeLog.md
|
||||
|
||||
# Metadata used when publishing your package
|
||||
# synopsis: Short description of your package
|
||||
# category: Web
|
||||
|
||||
# To avoid duplicated efforts in documentation and dealing with the
|
||||
# complications of embedding Haddock markup inside cabal files, it is
|
||||
# common to point users to the README.md file.
|
||||
description: Please see the README.md
|
||||
|
||||
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
|
||||
|
||||
dependencies:
|
||||
- base >= 4.11 && < 10
|
||||
- rio >= 0.1.12.0
|
||||
- dear-imgui
|
||||
- GLFW-b
|
||||
- managed
|
||||
- gl
|
||||
- aeson
|
||||
- data-default
|
||||
- directory
|
||||
- microlens-th
|
||||
- network
|
||||
- bytestring
|
||||
- stm
|
||||
- text
|
||||
- pretty-show
|
||||
- StateVar
|
||||
- type-iso
|
||||
- binary
|
||||
- time
|
||||
- unordered-containers
|
||||
- fingertree
|
||||
|
||||
ghc-options:
|
||||
- -Wall
|
||||
- -Wcompat
|
||||
- -Widentities
|
||||
- -Wincomplete-record-updates
|
||||
- -Wincomplete-uni-patterns
|
||||
- -Wpartial-fields
|
||||
- -Wredundant-constraints
|
||||
|
||||
library:
|
||||
source-dirs: src
|
||||
|
||||
executables:
|
||||
ibhelper-exe:
|
||||
main: Main.hs
|
||||
source-dirs: app
|
||||
dependencies:
|
||||
- ibhelper
|
||||
- optparse-simple
|
||||
|
||||
ghc-options:
|
||||
- -threaded
|
||||
- -rtsopts
|
||||
- -with-rtsopts=-N
|
||||
|
||||
tests:
|
||||
ibhelper-test:
|
||||
main: Spec.hs
|
||||
source-dirs: test
|
||||
dependencies:
|
||||
- ibhelper
|
||||
- hspec
|
||||
|
||||
ghc-options:
|
||||
- -threaded
|
||||
- -rtsopts
|
||||
- -with-rtsopts=-N
|
||||
79
src/AppFiller.hs
Normal file
79
src/AppFiller.hs
Normal file
@ -0,0 +1,79 @@
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
module AppFiller where
|
||||
|
||||
import Import
|
||||
import Types
|
||||
|
||||
import qualified Data.Text as T
|
||||
|
||||
import Data.Time
|
||||
import Data.FingerTree
|
||||
import Data.HashMap.Strict ((!?))
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
|
||||
|
||||
import qualified Debug.Trace as D
|
||||
|
||||
appFiller :: App -> IO ()
|
||||
appFiller app = runRIO app $ withRunInIO $ \run -> do
|
||||
let queue = twsConnectionRecieve . twsConnectionRefs . appRefs $ app
|
||||
debugMsg x = run $ logDebug (display $ T.pack $ "FILLER : " <> T.unpack x)
|
||||
infoMsg x = run $ logDebug (display $ T.pack $ "FILLER : " <> T.unpack x)
|
||||
forever $ do
|
||||
input <- atomically $ readTQueue queue
|
||||
let currentAppData = appData app
|
||||
case input of
|
||||
(Msg_IB_IN IB_PositionData) -> return ()
|
||||
(Msg_IB_IN (IB_ManagedAccts as)) -> do
|
||||
cur <- readTVarIO $ Types.accounts currentAppData
|
||||
actions <- forM as $ \a -> case cur !? a of
|
||||
Just _ -> return $ id
|
||||
Nothing -> do
|
||||
debugMsg $ "added Account "<> a
|
||||
return $ HM.insertWith const a (mkIBAccount a)
|
||||
atomically $ modifyTVar (Types.accounts currentAppData) $ foldl' (.) id actions
|
||||
(Msg_IB_IN (IB_NextValidID i)) -> atomically $ modifyTVar' (nextValidID currentAppData) (const (Just i))
|
||||
(Msg_IB_IN (IB_ErrorMsg i c m)) -> debugMsg "IB_ErrorMsg not implemented"
|
||||
(Msg_IB_IN (IB_AccountValue k v c n)) -> do
|
||||
let action = HM.update (\ai -> Just $ ai & accountInfo . accountProperties %~ HM.alter (\old -> Just $ (v,c):filter ((/=c) . snd) (fromMaybe [] old)) k) n
|
||||
atomically $ modifyTVar' (Types.accounts currentAppData) action
|
||||
(Msg_IB_IN (IB_AccountUpdateTime t)) -> debugMsg "IB_AccountUpdateTime not implemented"
|
||||
-- (Msg_IB_IN (IB_AccountUpdateTime t)) -> do
|
||||
-- let action = HM.update (\ai -> Just $ ai & accountInfo . accountLastUpdate %~ const t) n
|
||||
-- atomically $ modifyTVar' (Types.accounts currentAppData) action
|
||||
(Msg_IB_IN (IB_PortfolioValue c p mp mv ac u r n)) -> do
|
||||
let cid = conId :: IBContract -> Int
|
||||
updateAction (a@IBPortfolioValue{..}:as)
|
||||
| cid _contract == cid c = IBPortfolioValue c p mp mv ac u r:as
|
||||
| otherwise = a:updateAction as
|
||||
updateAction [] = [IBPortfolioValue c p mp mv ac u r]
|
||||
action = HM.update (\ai -> Just $ ai & accountPortfolio %~ updateAction) n
|
||||
atomically $ modifyTVar' (Types.accounts currentAppData) action
|
||||
(Msg_IB_IN (IB_SymbolSamples r s)) -> do
|
||||
atomically $ do
|
||||
modifyTVar' (nextValidID currentAppData) (const $ Just r)
|
||||
modifyTVar' (symbolLookupResults currentAppData) (const $ (\IB_SymbolSample{..} -> IBSymbolSample symId symbol secType primaryExchange currency derivatives) <$> s)
|
||||
(Msg_IB_IN t@IB_TickPrice{}) -> run $ handleTickPrice t
|
||||
_ -> --D.trace ("not implemented in AppFiller:" <> show input) $
|
||||
infoMsg $ "not implemented in AppFiller:" <> T.pack (show input)
|
||||
|
||||
|
||||
handleTickPrice :: IB_IN -> RIO App ()
|
||||
handleTickPrice IB_TickPrice{..} = do
|
||||
charts <- appCharts . appRefs <$> ask
|
||||
tid2symbol <- tickerIdToSymbol . appRefs <$> ask
|
||||
msymbol <- (HM.!? tickerId) <$> liftIO (readTVarIO tid2symbol)
|
||||
case msymbol of
|
||||
Nothing -> return () --ignore
|
||||
Just s -> do
|
||||
chartVar <- (HM.!s) <$> liftIO (readTVarIO charts)
|
||||
case tickType of
|
||||
IBTickType_Last_Price -> do
|
||||
t <- utctDayTime <$> liftIO getCurrentTime
|
||||
let cp = ChartPoint (TimePoint $ fromInteger. (`div` 1000000000000) . diffTimeToPicoseconds $ t) price []
|
||||
liftIO $ atomically $ modifyTVar chartVar (\c@Chart{..} -> c { chartData = chartData |> cp, chartDirty = True})
|
||||
_ -> return ()
|
||||
handleTickPrice _ = error "impossible"
|
||||
|
||||
|
||||
89
src/Chart.hs
Normal file
89
src/Chart.hs
Normal file
@ -0,0 +1,89 @@
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE DerivingVia #-}
|
||||
module Chart (newChart, FillerException(..)) where
|
||||
|
||||
import Import
|
||||
import Data.Time
|
||||
import RIO.List
|
||||
import RIO.List.Partial
|
||||
import Data.FingerTree (FingerTree)
|
||||
import Control.Concurrent (forkIO)
|
||||
import qualified RIO.ByteString as BS
|
||||
-- import Control.Exception
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
import qualified Data.FingerTree as FT
|
||||
|
||||
import qualified Debug.Trace as D
|
||||
|
||||
data FillerException = QuitFiller
|
||||
deriving Show
|
||||
|
||||
instance Exception FillerException
|
||||
|
||||
deriving via Integer instance Hashable Day
|
||||
|
||||
newChart :: IBContract -> RIO App ()
|
||||
newChart contract = do
|
||||
app <- ask
|
||||
let sym = (symbol :: IBContract -> Text) contract
|
||||
hmVar = appCharts . appRefs $ app
|
||||
hm <- liftIO . readTVarIO $ hmVar
|
||||
unless (sym `HM.member` hm) $ do
|
||||
c <- liftIO $ newTVarIO $ Chart FT.empty mempty undefined defChartSettings [] Nothing False
|
||||
tid <- liftIO $ forkIO $ fillChart app contract c
|
||||
liftIO $ atomically $ do
|
||||
modifyTVar' c (\Chart{..} -> let fillerThread = tid in Chart{..})
|
||||
modifyTVar' hmVar (HM.insert sym c)
|
||||
|
||||
fillChart :: App -> IBContract -> TVar Chart -> IO ()
|
||||
fillChart app contract cVar = runRIO app $ do
|
||||
let sym = (symbol :: IBContract -> Text) contract
|
||||
(tickerMapVar :: TVar (HashMap Int Text)) <- tickerIdToSymbol. appRefs <$> ask
|
||||
alreadyAdded <- (sym `elem`) . HM.elems <$> liftIO (readTVarIO tickerMapVar)
|
||||
unless alreadyAdded $ do
|
||||
tickerId <- (+1) . foldl' max 1000 . HM.keys <$> liftIO (readTVarIO tickerMapVar)
|
||||
let cancelSubscription = liftIO $ atomically $ do
|
||||
modifyTVar tickerMapVar (HM.delete tickerId)
|
||||
-- TODO: send cancel-request
|
||||
let sendQ = twsConnectionSend $ twsConnectionRefs $ appRefs $ app
|
||||
liftIO $ atomically $ do
|
||||
modifyTVar tickerMapVar (HM.insert tickerId sym)
|
||||
writeTQueue sendQ $ Msg_IB_OUT $ IB_RequestMktData tickerId contract "233" False False
|
||||
handle (\QuitFiller -> cancelSubscription >> exitSuccess) $
|
||||
forever $ do
|
||||
-- chart dirty? set clean & begin work
|
||||
Chart{..} <- liftIO (readTVarIO cVar)
|
||||
when chartDirty $ do
|
||||
liftIO $ atomically $ modifyTVar cVar (\c -> c { chartDirty = False })
|
||||
let (TimePoint cacheUpdateStart) = fromMaybe (TimePoint 0) Nothing -- TODO: lastCacheUpdate
|
||||
cacheUpdateEnd = 86400
|
||||
chunkChart :: Int -> Int -> Int -> FingerTree TimePoint ChartPoint -> [(TimePoint,[ChartPoint])]
|
||||
chunkChart from until range tree = go from range interval
|
||||
where
|
||||
lastItem = case FT.viewr interval of
|
||||
FT.EmptyR -> until
|
||||
(_ FT.:> ChartPoint{..}) -> (\(TimePoint x) -> x) timeOfDay
|
||||
interval = FT.takeUntil (\(TimePoint x) -> x > until)
|
||||
. FT.dropUntil (\(TimePoint x) -> x > from)
|
||||
$ tree
|
||||
go f i t
|
||||
| f+i >= lastItem = [(TimePoint (f+i), toList t)]
|
||||
| otherwise = let (a, b) = FT.split (\(TimePoint x) -> x > f+i) t
|
||||
in (TimePoint (f+i),toList a) : go (f+i) i b
|
||||
chunkedChart = chunkChart cacheUpdateStart cacheUpdateEnd (chartResolution chartSettings) chartData
|
||||
cachePoints = takeWhile (\ChartPoint{..} -> (\(TimePoint x) -> x < cacheUpdateStart) timeOfDay) chartCache <> map toCachePoint chunkedChart
|
||||
toCachePoint :: (TimePoint,[ChartPoint]) -> ChartPoint
|
||||
toCachePoint (t,[]) = ChartPoint t (-1) []
|
||||
toCachePoint (t,as) = ChartPoint t c [OLHC o l h c]
|
||||
where
|
||||
as' = pointValue <$> as
|
||||
o = head as'
|
||||
c = last as'
|
||||
l = minimum as'
|
||||
h = maximum as'
|
||||
let lUpdate = fmap fst . lastMaybe $ chunkedChart
|
||||
liftIO $ atomically $ modifyTVar cVar (\c -> c { chartCache = cachePoints, lastCacheUpdate = lUpdate })
|
||||
return ()
|
||||
threadDelay 1000000 -- sleep 5 seconds
|
||||
95
src/IBClient/Connection.hs
Normal file
95
src/IBClient/Connection.hs
Normal file
@ -0,0 +1,95 @@
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
module IBClient.Connection where
|
||||
|
||||
import Import
|
||||
|
||||
import Data.Binary
|
||||
import Network.Socket
|
||||
import Network.Socket.ByteString
|
||||
|
||||
import qualified Control.Exception as E
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Lazy as LBS
|
||||
import qualified Data.ByteString.Char8 as BS8
|
||||
import qualified Data.Text as T
|
||||
|
||||
forkClient :: App -> IO ()
|
||||
forkClient app = runRIO app $ withRunInIO $ \run -> withSocketsDo $ do
|
||||
let refs = twsConnectionRefs $ appRefs app
|
||||
toSend = twsConnectionSend refs
|
||||
toRecieve = twsConnectionRecieve refs
|
||||
cStatus = twsConnectionStatus refs
|
||||
debugSend x = run $ logDebug (display $ T.pack $ "SENT : " <> show x)
|
||||
debugRecv x = run $ logDebug (display $ T.pack $ "RECIEVED: " <> show x)
|
||||
connHost <- readTVarIO $ twsConnectionRefsHost refs
|
||||
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)
|
||||
run $ logDebug $ displayShow addr
|
||||
E.bracketOnError (socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)) close $ \sock -> do
|
||||
connect sock $ addrAddress addr
|
||||
let connStr = BS8.pack "API\0\0\0\0\tv100..157"
|
||||
sendAll sock connStr
|
||||
debugSend connStr
|
||||
answer <- recvAll sock
|
||||
run $ logDebug (displayShow (decode . LBS.fromStrict <$> answer :: Maybe IBGenericMessage))
|
||||
-- if we have the answer we are connected
|
||||
let idStr = LBS.toStrict $ encode $ IB_StartAPI "2" "69" -- version 2, client-id: 69
|
||||
sendAll sock idStr
|
||||
debugSend idStr
|
||||
atomically $ modifyTVar' cStatus (const TWSConnected)
|
||||
run $ logInfo $ display ("Connected to TWS" :: Text)
|
||||
let go True = do
|
||||
-- abort connection, close everything
|
||||
return ()
|
||||
go False = do
|
||||
-- race: wait for MSG in Queue or for answer on socket
|
||||
input <- race (atomically $ readTQueue toSend)
|
||||
(recvAll sock)
|
||||
case input of
|
||||
-- we want to disconnect
|
||||
Left IBDisconnect -> go True
|
||||
Left (Msg_IB_OUT x) -> do
|
||||
let msg = LBS.toStrict $ encode x
|
||||
debugSend msg
|
||||
sendAll sock msg
|
||||
-- we lost connection
|
||||
Right Nothing -> do
|
||||
atomically $ do
|
||||
writeTQueue toRecieve IBServerGone
|
||||
modifyTVar' cStatus (const TWSDisconnected)
|
||||
run $ logWarn $ display $ T.pack "Lost connection to TWS, reconnecting..."
|
||||
forkClient app
|
||||
Right (Just x) -> do debugRecv x
|
||||
parseMessage x
|
||||
where
|
||||
parseMessage "" = return ()
|
||||
parseMessage m = do
|
||||
let d = decodeOrFail @IB_IN (LBS.fromStrict m)
|
||||
case d of
|
||||
Right (rest, offset, result) -> do
|
||||
atomically $ writeTQueue toRecieve (Msg_IB_IN result)
|
||||
parseMessage (LBS.toStrict rest)
|
||||
Left (rest, offset, err) -> do
|
||||
run $ logInfo (display $ T.pack $ "Could not understand message: "<> ppShow err <> " ... skipping.\nRAW: " <> show m)
|
||||
if m == "\NUL" then do
|
||||
run $ logInfo (display $ T.pack "killing NUL")
|
||||
parseMessage (LBS.toStrict $ LBS.tail rest)
|
||||
else
|
||||
parseMessage (LBS.toStrict rest)
|
||||
go False
|
||||
go False
|
||||
|
||||
|
||||
recvAll :: Socket -> IO (Maybe ByteString)
|
||||
recvAll s = do
|
||||
d <- recv s 4096
|
||||
let l = BS.length d
|
||||
if
|
||||
| l == 0 -> return Nothing
|
||||
| l < 4096 -> return $ Just d
|
||||
| l == 4096 -> do
|
||||
next <- recvAll s
|
||||
return $ (d<>) <$> next
|
||||
| otherwise -> error "recvAll: recv got more bytes then requested. Impossible according to RFC"
|
||||
581
src/IBClient/Types.hs
Normal file
581
src/IBClient/Types.hs
Normal file
@ -0,0 +1,581 @@
|
||||
{-# HLINT ignore "Use camelCase" #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# OPTIONS_GHC -Wno-partial-fields #-}
|
||||
module IBClient.Types where
|
||||
|
||||
import Data.Binary
|
||||
import Data.Binary.Get
|
||||
import Data.Binary.Put
|
||||
import Data.Text.Encoding
|
||||
import Data.Maybe
|
||||
import Data.Default
|
||||
import Data.Aeson (FromJSON, ToJSON)
|
||||
import GHC.Enum (Enum(..))
|
||||
import RIO
|
||||
import RIO.List
|
||||
import RIO.List.Partial
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Char8 as BS8
|
||||
import qualified Data.ByteString.Lazy as LBS
|
||||
import qualified Data.ByteString.Lazy.Char8 as LBS8
|
||||
|
||||
|
||||
import qualified Debug.Trace as D
|
||||
|
||||
data Msg_IB_OUT = IBDisconnect
|
||||
| Msg_IB_OUT IB_OUT
|
||||
deriving (Show, Eq)
|
||||
|
||||
data Msg_IB_IN = IBServerGone
|
||||
| Msg_IB_IN IB_IN
|
||||
deriving (Show, Eq)
|
||||
|
||||
data IBTypes = IBString ByteString
|
||||
| IBBool Bool
|
||||
| IBArray [ByteString]
|
||||
deriving (Show, Eq)
|
||||
|
||||
toBS :: IBTypes -> ByteString
|
||||
toBS (IBString t) = t
|
||||
toBS (IBArray a) = (BS8.pack . show . length $ a) <> BS.intercalate "\0" a <> "\0"
|
||||
toBS (IBBool True) = "1"--BS.pack [0,0,0,1] -- bool == 32-bit int in IB
|
||||
toBS (IBBool False) = "0"--BS.pack [0,0,0,0] -- bool == 32-bit int in IB
|
||||
|
||||
newtype IBGenericMessage = IBGenericMessage
|
||||
{ fields :: [IBTypes]
|
||||
} deriving (Show, Eq)
|
||||
|
||||
instance Binary IBGenericMessage where
|
||||
put (IBGenericMessage f) = do
|
||||
let msg = BS.intercalate "\0" (toBS <$> f) <> "\0"
|
||||
putWord32be . fromIntegral . BS.length $ msg
|
||||
putByteString msg
|
||||
get = do
|
||||
len <- getWord32be
|
||||
D.traceShow len $ return ()
|
||||
fields <- BS.split 0 . BS.init <$> getByteString (fromIntegral len)
|
||||
D.traceShow fields $ return ()
|
||||
return $ IBGenericMessage $ IBString <$> fields
|
||||
|
||||
data IB_OUT = IB_StartAPI { version :: Text, clientId :: Text }
|
||||
| IB_RequestPositions
|
||||
| IB_RequestAccountData { subscribe :: Bool, acctCode :: Text }
|
||||
| IB_RequestMatchingSymbol { reqId :: Int, symbol :: Text }
|
||||
| IB_RequestMarketDataType { dataType :: IBMarketDataType }
|
||||
| IB_RequestMktData { tickerId :: Int, contract :: IBContract, genericTickList :: Text, snapshot :: Bool, regulatorySnapshot :: Bool }
|
||||
deriving (Show, Eq)
|
||||
|
||||
tToIB :: Text -> IBTypes
|
||||
tToIB = IBString . encodeUtf8
|
||||
|
||||
iToIB :: Int -> IBTypes
|
||||
iToIB = IBString . BS8.pack . show
|
||||
|
||||
fToIB :: Float -> IBTypes
|
||||
fToIB = IBString . BS8.pack . show
|
||||
|
||||
clToIB :: [IBComboLeg] -> [IBTypes]
|
||||
clToIB as = iToIB (length as) : concatMap (\IBComboLeg{..} -> [iToIB conId, iToIB ratio, tToIB action, tToIB exchange]) as
|
||||
|
||||
dncToIB :: Maybe IBDeltaNeutralContract -> [IBTypes]
|
||||
dncToIB Nothing = []
|
||||
dncToIB (Just IBDeltaNeutralContract{..}) = [iToIB 1, iToIB conId, fToIB delta, fToIB price]
|
||||
|
||||
instance Binary IB_OUT where
|
||||
put (IB_StartAPI v c) = put (IBGenericMessage [IBString "71", tToIB v, tToIB c, IBString ""])
|
||||
put IB_RequestPositions = put (IBGenericMessage [IBString "61", IBString "v"])
|
||||
put (IB_RequestAccountData s a) = put (IBGenericMessage [IBString "6", IBString "2", IBBool s, tToIB a])
|
||||
put (IB_RequestMatchingSymbol i s) = put (IBGenericMessage [IBString "81", iToIB i, tToIB s])
|
||||
put (IB_RequestMktData t IBContract{..} l s r) = put $ D.traceShowId (IBGenericMessage $ [IBString "1", IBString "11", iToIB t, iToIB conId, tToIB symbol, tToIB secType, tToIB lastTradeDate, fToIB strike, tToIB right, tToIB multiplier, tToIB exchange, tToIB primaryExchange, tToIB currency, tToIB localSymbol, tToIB tradingClass] <> clToIB comboLegs <> dncToIB deltaNeutralContract <> [tToIB l, iToIB (if s then 1 else 0), iToIB (if r then 1 else 0), tToIB ""])
|
||||
put (IB_RequestMarketDataType t) = put (IBGenericMessage [IBString "59", IBString "1", iToIB $ fromEnum t])
|
||||
|
||||
get = do f <- fmap (\(IBString x) -> x) . fields <$> get
|
||||
case headMaybe f of
|
||||
Just "71" -> return $ IB_StartAPI (decodeUtf8 $ f!!1) (decodeUtf8 $ f!!2)
|
||||
Just "6" -> return $ IB_RequestAccountData {- ignore version -} (all (==0) . BS.unpack $ f!!2) (decodeUtf8 $ f!!3)
|
||||
Just "59" -> return $ IB_RequestMarketDataType {- ignore version -} (toEnum . fromJust . readMaybe . BS8.unpack $ f!!2)
|
||||
Just x -> fail $ "unkonwn IB_OUT type" <> BS8.unpack x
|
||||
Nothing -> fail $ "No Fields"
|
||||
|
||||
data IBContract = IBContract
|
||||
{ conId :: Int
|
||||
, symbol :: Text
|
||||
, secType :: Text
|
||||
, lastTradeDate :: Text
|
||||
, strike :: Float
|
||||
, right :: Text
|
||||
, multiplier :: Text
|
||||
, exchange :: Text -- ^ can be SMART
|
||||
, primaryExchange :: Text -- ^ actual exchange - MUST NOT BE SMART
|
||||
, currency :: Text
|
||||
, localSymbol :: Text
|
||||
, tradingClass :: Text
|
||||
, includeExpired :: Bool
|
||||
, secIdType :: Text
|
||||
, secId :: Text
|
||||
, comboLegsDescrip :: Text -- ^ received in open order 14 and up for all combos
|
||||
, comboLegs :: [IBComboLeg]
|
||||
, deltaNeutralContract :: Maybe IBDeltaNeutralContract
|
||||
} deriving (Show, Eq, Generic)
|
||||
deriving anyclass (FromJSON, ToJSON)
|
||||
|
||||
instance Default IBContract where
|
||||
def = IBContract 0 "" "" "" 0 "" "" "" "" "" "" "" False "" "" "" [] Nothing
|
||||
|
||||
data IBComboLeg = IBComboLeg
|
||||
{ conId :: Int
|
||||
, ratio :: Int
|
||||
, action :: Text -- ^ BUY/SELL/SSHORT
|
||||
, exchange :: Text
|
||||
, openClose :: Int -- ^ LegOpenClose enum values
|
||||
, shortSaleSlot :: Int
|
||||
, designatedLocation :: Text
|
||||
, exemptCode :: Int
|
||||
} deriving (Show, Eq, Generic)
|
||||
deriving anyclass (FromJSON, ToJSON)
|
||||
|
||||
instance Default IBComboLeg where
|
||||
def = IBComboLeg 0 0 "" "" 0 0 "" (negate 1)
|
||||
|
||||
data IBDeltaNeutralContract = IBDeltaNeutralContract
|
||||
{ conId :: Int
|
||||
, delta :: Float
|
||||
, price :: Float
|
||||
} deriving (Show, Eq, Generic)
|
||||
deriving anyclass (FromJSON, ToJSON)
|
||||
|
||||
instance Default IBDeltaNeutralContract where
|
||||
def = IBDeltaNeutralContract 0 0 0
|
||||
|
||||
data IBMarketDataType = RealTime
|
||||
| Frozen
|
||||
| Delayed
|
||||
| DelayedFrozen
|
||||
deriving (Show, Eq, Generic)
|
||||
deriving anyclass (FromJSON, ToJSON)
|
||||
|
||||
instance Default IBMarketDataType where
|
||||
def = DelayedFrozen
|
||||
|
||||
instance Enum IBMarketDataType where
|
||||
toEnum 1 = RealTime
|
||||
toEnum 2 = Frozen
|
||||
toEnum 3 = Delayed
|
||||
toEnum 4 = DelayedFrozen
|
||||
toEnum _ = def
|
||||
fromEnum RealTime = 1
|
||||
fromEnum Frozen = 2
|
||||
fromEnum Delayed = 3
|
||||
fromEnum DelayedFrozen = 4
|
||||
|
||||
data IBTickType = Unknown Int
|
||||
| IBTickType_Bid_Size
|
||||
| IBTickType_Bid_Price
|
||||
| IBTickType_Ask_Price
|
||||
| IBTickType_Ask_Size
|
||||
| IBTickType_Last_Price
|
||||
| IBTickType_Last_Size
|
||||
| IBTickType_High
|
||||
| IBTickType_Low
|
||||
| IBTickType_Volume
|
||||
| IBTickType_Close_Price
|
||||
| IBTickType_Bid_Option_Computation
|
||||
| IBTickType_Ask_Option_Computation
|
||||
| IBTickType_Last_Option_Computation
|
||||
| IBTickType_Model_Option_Computation
|
||||
| IBTickType_Open_Tick
|
||||
| IBTickType_Low_13_Weeks
|
||||
| IBTickType_High_13_Weeks
|
||||
| IBTickType_Low_26_Weeks
|
||||
| IBTickType_High_26_Weeks
|
||||
| IBTickType_Low_52_Weeks
|
||||
| IBTickType_High_52_Weeks
|
||||
| IBTickType_Average_Volume
|
||||
| IBTickType_Open_Interest
|
||||
| IBTickType_Option_Historical_Volatility
|
||||
| IBTickType_Option_Implied_Volatility
|
||||
| IBTickType_Option_Bid_Exchange
|
||||
| IBTickType_Option_Ask_Exchange
|
||||
| IBTickType_Option_Call_Open_Interest
|
||||
| IBTickType_Option_Put_Open_Interest
|
||||
| IBTickType_Option_Call_Volume
|
||||
| IBTickType_Option_Put_Volume
|
||||
| IBTickType_Index_Future_Premium
|
||||
| IBTickType_Bid_Exchange
|
||||
| IBTickType_Ask_Exchange
|
||||
| IBTickType_Auction_Volume
|
||||
| IBTickType_Auction_Price
|
||||
| IBTickType_Auction_Imbalance
|
||||
| IBTickType_Mark_Price
|
||||
| IBTickType_Bid_EFP_Computation
|
||||
| IBTickType_Ask_EFP_Computation
|
||||
| IBTickType_Last_EFP_Computation
|
||||
| IBTickType_Open_EFP_Computation
|
||||
| IBTickType_High_EFP_Computation
|
||||
| IBTickType_Low_EFP_Computation
|
||||
| IBTickType_Close_EFP_Computation
|
||||
| IBTickType_Last_Timestamp
|
||||
| IBTickType_Shortable
|
||||
| IBTickType_RT_Volume
|
||||
| IBTickType_Halted
|
||||
| IBTickType_Bid_Yield
|
||||
| IBTickType_Ask_Yield
|
||||
| IBTickType_Last_Yield
|
||||
| IBTickType_Custom_Option_Computation
|
||||
| IBTickType_Trade_Count
|
||||
| IBTickType_Trade_Rate
|
||||
| IBTickType_Volume_Rate
|
||||
| IBTickType_Last_RTH_Trade
|
||||
| IBTickType_RT_Historical_Volatility
|
||||
| IBTickType_IB_Dividends
|
||||
| IBTickType_Bond_Factor_Multiplier
|
||||
| IBTickType_Regulatory_Imbalance
|
||||
| IBTickType_News
|
||||
| IBTickType_ShortTerm_Volume_3_Minutes
|
||||
| IBTickType_ShortTerm_Volume_5_Minutes
|
||||
| IBTickType_ShortTerm_Volume_10_Minutes
|
||||
| IBTickType_Delayed_Bid
|
||||
| IBTickType_Delayed_Ask
|
||||
| IBTickType_Delayed_Last
|
||||
| IBTickType_Delayed_Bid_Size
|
||||
| IBTickType_Delayed_Ask_Size
|
||||
| IBTickType_Delayed_Last_Size
|
||||
| IBTickType_Delayed_High_Price
|
||||
| IBTickType_Delayed_Low_Price
|
||||
| IBTickType_Delayed_Volume
|
||||
| IBTickType_Delayed_Close
|
||||
| IBTickType_Delayed_Open
|
||||
| IBTickType_RT_Trade_Volume
|
||||
| IBTickType_Creditman_mark_price
|
||||
| IBTickType_Creditman_slow_mark_price
|
||||
| IBTickType_Delayed_Bid_Option
|
||||
| IBTickType_Delayed_Ask_Option
|
||||
| IBTickType_Delayed_Last_Option
|
||||
| IBTickType_Delayed_Model_Option
|
||||
| IBTickType_Last_Exchange
|
||||
| IBTickType_Last_Regulatory_Time
|
||||
| IBTickType_Futures_Open_Interest
|
||||
| IBTickType_Average_Option_Volume
|
||||
| IBTickType_Delayed_Last_Timestamp
|
||||
| IBTickType_Shortable_Shares
|
||||
| IBTickType_ETF_Nav_Close
|
||||
| IBTickType_ETF_Nav_Prior_Close
|
||||
| IBTickType_ETF_Nav_Bid
|
||||
| IBTickType_ETF_Nav_Ask
|
||||
| IBTickType_ETF_Nav_Last
|
||||
| IBTickType_ETF_Nav_Frozen_Last
|
||||
| IBTickType_ETF_Nav_High
|
||||
| IBTickType_ETF_Nav_Low
|
||||
deriving (Show, Eq)
|
||||
|
||||
instance Enum IBTickType where
|
||||
toEnum 0 = IBTickType_Bid_Size
|
||||
toEnum 1 = IBTickType_Bid_Price
|
||||
toEnum 2 = IBTickType_Ask_Price
|
||||
toEnum 3 = IBTickType_Ask_Size
|
||||
toEnum 4 = IBTickType_Last_Price
|
||||
toEnum 5 = IBTickType_Last_Size
|
||||
toEnum 6 = IBTickType_High
|
||||
toEnum 7 = IBTickType_Low
|
||||
toEnum 8 = IBTickType_Volume
|
||||
toEnum 9 = IBTickType_Close_Price
|
||||
toEnum 10 = IBTickType_Bid_Option_Computation
|
||||
toEnum 11 = IBTickType_Ask_Option_Computation
|
||||
toEnum 12 = IBTickType_Last_Option_Computation
|
||||
toEnum 13 = IBTickType_Model_Option_Computation
|
||||
toEnum 14 = IBTickType_Open_Tick
|
||||
toEnum 15 = IBTickType_Low_13_Weeks
|
||||
toEnum 16 = IBTickType_High_13_Weeks
|
||||
toEnum 17 = IBTickType_Low_26_Weeks
|
||||
toEnum 18 = IBTickType_High_26_Weeks
|
||||
toEnum 19 = IBTickType_Low_52_Weeks
|
||||
toEnum 20 = IBTickType_High_52_Weeks
|
||||
toEnum 21 = IBTickType_Average_Volume
|
||||
toEnum 22 = IBTickType_Open_Interest
|
||||
toEnum 23 = IBTickType_Option_Historical_Volatility
|
||||
toEnum 24 = IBTickType_Option_Implied_Volatility
|
||||
toEnum 25 = IBTickType_Option_Bid_Exchange
|
||||
toEnum 26 = IBTickType_Option_Ask_Exchange
|
||||
toEnum 27 = IBTickType_Option_Call_Open_Interest
|
||||
toEnum 28 = IBTickType_Option_Put_Open_Interest
|
||||
toEnum 29 = IBTickType_Option_Call_Volume
|
||||
toEnum 30 = IBTickType_Option_Put_Volume
|
||||
toEnum 31 = IBTickType_Index_Future_Premium
|
||||
toEnum 32 = IBTickType_Bid_Exchange
|
||||
toEnum 33 = IBTickType_Ask_Exchange
|
||||
toEnum 34 = IBTickType_Auction_Volume
|
||||
toEnum 35 = IBTickType_Auction_Price
|
||||
toEnum 36 = IBTickType_Auction_Imbalance
|
||||
toEnum 37 = IBTickType_Mark_Price
|
||||
toEnum 38 = IBTickType_Bid_EFP_Computation
|
||||
toEnum 39 = IBTickType_Ask_EFP_Computation
|
||||
toEnum 40 = IBTickType_Last_EFP_Computation
|
||||
toEnum 41 = IBTickType_Open_EFP_Computation
|
||||
toEnum 42 = IBTickType_High_EFP_Computation
|
||||
toEnum 43 = IBTickType_Low_EFP_Computation
|
||||
toEnum 44 = IBTickType_Close_EFP_Computation
|
||||
toEnum 45 = IBTickType_Last_Timestamp
|
||||
toEnum 46 = IBTickType_Shortable
|
||||
toEnum 48 = IBTickType_RT_Volume
|
||||
toEnum 49 = IBTickType_Halted
|
||||
toEnum 50 = IBTickType_Bid_Yield
|
||||
toEnum 51 = IBTickType_Ask_Yield
|
||||
toEnum 52 = IBTickType_Last_Yield
|
||||
toEnum 53 = IBTickType_Custom_Option_Computation
|
||||
toEnum 54 = IBTickType_Trade_Count
|
||||
toEnum 55 = IBTickType_Trade_Rate
|
||||
toEnum 56 = IBTickType_Volume_Rate
|
||||
toEnum 57 = IBTickType_Last_RTH_Trade
|
||||
toEnum 58 = IBTickType_RT_Historical_Volatility
|
||||
toEnum 59 = IBTickType_IB_Dividends
|
||||
toEnum 60 = IBTickType_Bond_Factor_Multiplier
|
||||
toEnum 61 = IBTickType_Regulatory_Imbalance
|
||||
toEnum 62 = IBTickType_News
|
||||
toEnum 63 = IBTickType_ShortTerm_Volume_3_Minutes
|
||||
toEnum 64 = IBTickType_ShortTerm_Volume_5_Minutes
|
||||
toEnum 65 = IBTickType_ShortTerm_Volume_10_Minutes
|
||||
toEnum 66 = IBTickType_Delayed_Bid
|
||||
toEnum 67 = IBTickType_Delayed_Ask
|
||||
toEnum 68 = IBTickType_Delayed_Last
|
||||
toEnum 69 = IBTickType_Delayed_Bid_Size
|
||||
toEnum 70 = IBTickType_Delayed_Ask_Size
|
||||
toEnum 71 = IBTickType_Delayed_Last_Size
|
||||
toEnum 72 = IBTickType_Delayed_High_Price
|
||||
toEnum 73 = IBTickType_Delayed_Low_Price
|
||||
toEnum 74 = IBTickType_Delayed_Volume
|
||||
toEnum 75 = IBTickType_Delayed_Close
|
||||
toEnum 76 = IBTickType_Delayed_Open
|
||||
toEnum 77 = IBTickType_RT_Trade_Volume
|
||||
toEnum 78 = IBTickType_Creditman_mark_price
|
||||
toEnum 79 = IBTickType_Creditman_slow_mark_price
|
||||
toEnum 80 = IBTickType_Delayed_Bid_Option
|
||||
toEnum 81 = IBTickType_Delayed_Ask_Option
|
||||
toEnum 82 = IBTickType_Delayed_Last_Option
|
||||
toEnum 83 = IBTickType_Delayed_Model_Option
|
||||
toEnum 84 = IBTickType_Last_Exchange
|
||||
toEnum 85 = IBTickType_Last_Regulatory_Time
|
||||
toEnum 86 = IBTickType_Futures_Open_Interest
|
||||
toEnum 87 = IBTickType_Average_Option_Volume
|
||||
toEnum 88 = IBTickType_Delayed_Last_Timestamp
|
||||
toEnum 89 = IBTickType_Shortable_Shares
|
||||
toEnum 92 = IBTickType_ETF_Nav_Close
|
||||
toEnum 93 = IBTickType_ETF_Nav_Prior_Close
|
||||
toEnum 94 = IBTickType_ETF_Nav_Bid
|
||||
toEnum 95 = IBTickType_ETF_Nav_Ask
|
||||
toEnum 96 = IBTickType_ETF_Nav_Last
|
||||
toEnum 97 = IBTickType_ETF_Nav_Frozen_Last
|
||||
toEnum 98 = IBTickType_ETF_Nav_High
|
||||
toEnum 99 = IBTickType_ETF_Nav_Low
|
||||
toEnum x = D.trace ("Unknown tick-type-id: " <> show x) $ Unknown x
|
||||
fromEnum (Unknown x) = x
|
||||
fromEnum IBTickType_Bid_Size = 0
|
||||
fromEnum IBTickType_Bid_Price = 1
|
||||
fromEnum IBTickType_Ask_Price = 2
|
||||
fromEnum IBTickType_Ask_Size = 3
|
||||
fromEnum IBTickType_Last_Price = 4
|
||||
fromEnum IBTickType_Last_Size = 5
|
||||
fromEnum IBTickType_High = 6
|
||||
fromEnum IBTickType_Low = 7
|
||||
fromEnum IBTickType_Volume = 8
|
||||
fromEnum IBTickType_Close_Price = 9
|
||||
fromEnum IBTickType_Bid_Option_Computation = 10
|
||||
fromEnum IBTickType_Ask_Option_Computation = 11
|
||||
fromEnum IBTickType_Last_Option_Computation = 12
|
||||
fromEnum IBTickType_Model_Option_Computation = 13
|
||||
fromEnum IBTickType_Open_Tick = 14
|
||||
fromEnum IBTickType_Low_13_Weeks = 15
|
||||
fromEnum IBTickType_High_13_Weeks = 16
|
||||
fromEnum IBTickType_Low_26_Weeks = 17
|
||||
fromEnum IBTickType_High_26_Weeks = 18
|
||||
fromEnum IBTickType_Low_52_Weeks = 19
|
||||
fromEnum IBTickType_High_52_Weeks = 20
|
||||
fromEnum IBTickType_Average_Volume = 21
|
||||
fromEnum IBTickType_Open_Interest = 22
|
||||
fromEnum IBTickType_Option_Historical_Volatility = 23
|
||||
fromEnum IBTickType_Option_Implied_Volatility = 24
|
||||
fromEnum IBTickType_Option_Bid_Exchange = 25
|
||||
fromEnum IBTickType_Option_Ask_Exchange = 26
|
||||
fromEnum IBTickType_Option_Call_Open_Interest = 27
|
||||
fromEnum IBTickType_Option_Put_Open_Interest = 28
|
||||
fromEnum IBTickType_Option_Call_Volume = 29
|
||||
fromEnum IBTickType_Option_Put_Volume = 30
|
||||
fromEnum IBTickType_Index_Future_Premium = 31
|
||||
fromEnum IBTickType_Bid_Exchange = 32
|
||||
fromEnum IBTickType_Ask_Exchange = 33
|
||||
fromEnum IBTickType_Auction_Volume = 34
|
||||
fromEnum IBTickType_Auction_Price = 35
|
||||
fromEnum IBTickType_Auction_Imbalance = 36
|
||||
fromEnum IBTickType_Mark_Price = 37
|
||||
fromEnum IBTickType_Bid_EFP_Computation = 38
|
||||
fromEnum IBTickType_Ask_EFP_Computation = 39
|
||||
fromEnum IBTickType_Last_EFP_Computation = 40
|
||||
fromEnum IBTickType_Open_EFP_Computation = 41
|
||||
fromEnum IBTickType_High_EFP_Computation = 42
|
||||
fromEnum IBTickType_Low_EFP_Computation = 43
|
||||
fromEnum IBTickType_Close_EFP_Computation = 44
|
||||
fromEnum IBTickType_Last_Timestamp = 45
|
||||
fromEnum IBTickType_Shortable = 46
|
||||
fromEnum IBTickType_RT_Volume = 48
|
||||
fromEnum IBTickType_Halted = 49
|
||||
fromEnum IBTickType_Bid_Yield = 50
|
||||
fromEnum IBTickType_Ask_Yield = 51
|
||||
fromEnum IBTickType_Last_Yield = 52
|
||||
fromEnum IBTickType_Custom_Option_Computation = 53
|
||||
fromEnum IBTickType_Trade_Count = 54
|
||||
fromEnum IBTickType_Trade_Rate = 55
|
||||
fromEnum IBTickType_Volume_Rate = 56
|
||||
fromEnum IBTickType_Last_RTH_Trade = 57
|
||||
fromEnum IBTickType_RT_Historical_Volatility = 58
|
||||
fromEnum IBTickType_IB_Dividends = 59
|
||||
fromEnum IBTickType_Bond_Factor_Multiplier = 60
|
||||
fromEnum IBTickType_Regulatory_Imbalance = 61
|
||||
fromEnum IBTickType_News = 62
|
||||
fromEnum IBTickType_ShortTerm_Volume_3_Minutes = 63
|
||||
fromEnum IBTickType_ShortTerm_Volume_5_Minutes = 64
|
||||
fromEnum IBTickType_ShortTerm_Volume_10_Minutes = 65
|
||||
fromEnum IBTickType_Delayed_Bid = 66
|
||||
fromEnum IBTickType_Delayed_Ask = 67
|
||||
fromEnum IBTickType_Delayed_Last = 68
|
||||
fromEnum IBTickType_Delayed_Bid_Size = 69
|
||||
fromEnum IBTickType_Delayed_Ask_Size = 70
|
||||
fromEnum IBTickType_Delayed_Last_Size = 71
|
||||
fromEnum IBTickType_Delayed_High_Price = 72
|
||||
fromEnum IBTickType_Delayed_Low_Price = 73
|
||||
fromEnum IBTickType_Delayed_Volume = 74
|
||||
fromEnum IBTickType_Delayed_Close = 75
|
||||
fromEnum IBTickType_Delayed_Open = 76
|
||||
fromEnum IBTickType_RT_Trade_Volume = 77
|
||||
fromEnum IBTickType_Creditman_mark_price = 78
|
||||
fromEnum IBTickType_Creditman_slow_mark_price = 79
|
||||
fromEnum IBTickType_Delayed_Bid_Option = 80
|
||||
fromEnum IBTickType_Delayed_Ask_Option = 81
|
||||
fromEnum IBTickType_Delayed_Last_Option = 82
|
||||
fromEnum IBTickType_Delayed_Model_Option = 83
|
||||
fromEnum IBTickType_Last_Exchange = 84
|
||||
fromEnum IBTickType_Last_Regulatory_Time = 85
|
||||
fromEnum IBTickType_Futures_Open_Interest = 86
|
||||
fromEnum IBTickType_Average_Option_Volume = 87
|
||||
fromEnum IBTickType_Delayed_Last_Timestamp = 88
|
||||
fromEnum IBTickType_Shortable_Shares = 89
|
||||
fromEnum IBTickType_ETF_Nav_Close = 92
|
||||
fromEnum IBTickType_ETF_Nav_Prior_Close = 93
|
||||
fromEnum IBTickType_ETF_Nav_Bid = 94
|
||||
fromEnum IBTickType_ETF_Nav_Ask = 95
|
||||
fromEnum IBTickType_ETF_Nav_Last = 96
|
||||
fromEnum IBTickType_ETF_Nav_Frozen_Last = 97
|
||||
fromEnum IBTickType_ETF_Nav_High = 98
|
||||
fromEnum IBTickType_ETF_Nav_Low = 99
|
||||
|
||||
type IB_DerivativeSecType = Text
|
||||
|
||||
data IB_SymbolSample = IB_SymbolSample
|
||||
{ symId :: Int
|
||||
, symbol :: Text
|
||||
, secType :: Text
|
||||
, primaryExchange :: Text
|
||||
, currency :: Text
|
||||
, derivatives :: [IB_DerivativeSecType]
|
||||
} deriving (Show, Eq)
|
||||
|
||||
data IB_IN = IB_PositionData
|
||||
| IB_ManagedAccts { accounts :: [Text] }
|
||||
| IB_NextValidID { orderID :: Int }
|
||||
| IB_ErrorMsg { errorID :: Int, errorCode :: Int, errorMsg :: Text }
|
||||
| IB_AccountValue { key :: Text, value :: Text, currency :: Text, accountName :: Text }
|
||||
| IB_AccountUpdateTime { time :: Text }
|
||||
| IB_PortfolioValue { contract :: IBContract, position :: Float, marketPrice :: Float, marketValue :: Float, averageCost :: Float, unrealizedPNL :: Float, realizedPNL :: Float, accountName :: Text }
|
||||
| IB_SymbolSamples { nextId :: Int, samples :: [IB_SymbolSample] }
|
||||
| IB_MarketDataType { tickerId :: Int, dataType :: IBMarketDataType }
|
||||
| IB_TickReqParams { tickerId :: Int, minTick :: Float, bboExchange :: Text, snapshotPermissions :: Int }
|
||||
| IB_TickPrice { tickerId :: Int, tickType :: IBTickType, price :: Float, size :: Int, attrMask :: Int }
|
||||
| IB_TickSize { tickerId :: Int, fieldId :: Int, size :: Int } -- TODO: field is an enum
|
||||
| IB_TickString { tickerId :: Int, tickType :: IBTickType, content :: Text }
|
||||
deriving (Show, Eq)
|
||||
|
||||
voidVersion :: LBS.ByteString -> LBS.ByteString -> Get ()
|
||||
voidVersion t v = do
|
||||
version <- getLazyByteStringNul
|
||||
when (version /= v) $ D.trace ("Unexpected Version '" <> LBS8.unpack version <> "' for Message-Type " <> LBS8.unpack t <> ". Expected: '" <> LBS8.unpack v <> "'.") (return ())
|
||||
|
||||
instance Binary IB_IN where
|
||||
put (IB_ErrorMsg i c m) = put (IBGenericMessage [IBString "4", IBString "2", IBString $ BS8.pack $ show i, IBString $ BS8.pack $ show c, tToIB m])
|
||||
put (IB_AccountValue k v c n) = put (IBGenericMessage [IBString "6", IBString "2", tToIB k, tToIB v, tToIB c, tToIB n])
|
||||
put (IB_PortfolioValue IBContract{..} p pp v c u r n) = put $ IBGenericMessage [ IBString "7", IBString "8" -- id/version
|
||||
, iToIB conId, tToIB symbol, tToIB secType, tToIB lastTradeDate, fToIB strike, tToIB right, tToIB multiplier, tToIB primaryExchange, tToIB currency, tToIB localSymbol, tToIB tradingClass -- contract
|
||||
, fToIB p, fToIB pp, fToIB v, fToIB c, fToIB u, fToIB r, tToIB n
|
||||
]
|
||||
put (IB_AccountUpdateTime t) = put (IBGenericMessage [IBString "8", IBString "1", tToIB t])
|
||||
put (IB_NextValidID v) = put (IBGenericMessage [IBString "9", IBString "1", IBString $ BS8.pack $ show v])
|
||||
put (IB_ManagedAccts a) = put (IBGenericMessage [IBString "15", IBArray $ encodeUtf8 <$> a])
|
||||
put IB_PositionData = put (IBGenericMessage [IBString "61"])
|
||||
put IB_SymbolSamples{} = error "not implemented"
|
||||
put IB_MarketDataType{} = error "not implemented"
|
||||
put IB_TickReqParams{} = error "not implemented"
|
||||
put IB_TickPrice{} = error "not implemented"
|
||||
put IB_TickSize{} = error "not implemented"
|
||||
put IB_TickString{} = error "not implemented"
|
||||
--put (IB_SymbolSamples r s) = put (IBGenericMessage [IBString "79", IBString "1", iToIB r, IBArray $ s]) TODO: FIXME
|
||||
|
||||
get = do
|
||||
msglen <- getWord32be
|
||||
when (msglen == 0) $ fail "empty message"
|
||||
ident <- return <$> getLazyByteStringNul
|
||||
case ident of
|
||||
Just "1" -> do
|
||||
voidVersion "1" "6"
|
||||
IB_TickPrice <$> ib2int <*> (toEnum <$> ib2int) <*> ib2f <*> ib2int <*> ib2int
|
||||
Just "2" -> do
|
||||
voidVersion "2" "6"
|
||||
IB_TickSize <$> ib2int <*> ib2int <*> ib2int
|
||||
Just "4" -> do
|
||||
voidVersion "4" "2"
|
||||
IB_ErrorMsg <$> ib2int <*> ib2int <*> ib2txt
|
||||
Just "6" -> do
|
||||
voidVersion "6" "2"
|
||||
IB_AccountValue <$> ib2txt <*> ib2txt <*> ib2txt <*> ib2txt
|
||||
Just "7" -> do
|
||||
voidVersion "7" "8"
|
||||
c <- IBContract <$> ib2int <*> ib2txt <*> ib2txt <*> ib2txt <*> ib2f <*> ib2txt <*> ib2txt <*> pure "" <*> ib2txt <*> ib2txt <*> ib2txt <*> ib2txt
|
||||
IB_PortfolioValue (c False "" "" "" [] Nothing) <$> ib2f <*> ib2f <*> ib2f <*> ib2f <*> ib2f <*> ib2f <*> ib2txt
|
||||
Just "8" -> do
|
||||
voidVersion "8" "1"
|
||||
IB_AccountUpdateTime <$> ib2txt
|
||||
Just "9" -> do
|
||||
voidVersion "9" "1"
|
||||
IB_NextValidID <$> ib2int
|
||||
Just "15" -> do
|
||||
len <- ib2int
|
||||
IB_ManagedAccts <$> forM [1..len] (const ib2txt)
|
||||
Just "46" -> do
|
||||
voidVersion "46" "6"
|
||||
IB_TickString <$> ib2int <*> (toEnum <$> ib2int) <*> ib2txt
|
||||
Just "58" -> do
|
||||
voidVersion "58" "1"
|
||||
IB_MarketDataType <$> ib2int <*> (toEnum <$> ib2int)
|
||||
Just "61" -> return IB_PositionData
|
||||
Just "79" -> do
|
||||
reqId <- ib2int
|
||||
len <- ib2int
|
||||
symsamples <- forM [1..len] $ const $ do
|
||||
f <- IB_SymbolSample <$> ib2int <*> ib2txt <*> ib2txt <*> ib2txt <*> ib2txt
|
||||
n <- ib2int
|
||||
derivatives <- forM [1..n] $ const ib2txt
|
||||
return $ f derivatives
|
||||
return $ IB_SymbolSamples reqId symsamples
|
||||
Just "81" -> do
|
||||
IB_TickReqParams <$> ib2int <*> ib2f <*> ib2txt <*> ib2int
|
||||
Just x -> do
|
||||
payload <- getByteString (fromIntegral msglen - (if null ident then 0 else length ident + 1) - 1) -- drop rest of message
|
||||
D.trace ("Payload for "<> LBS8.unpack x <> " not understood: " <> show (IBGenericMessage $ fmap IBString . BS.split 0 . BS.init $ payload)) $ return ()
|
||||
fail $ "unkonwn IB_IN type " <> LBS8.unpack x
|
||||
Nothing -> fail "Cannot decode Message: no identifier"
|
||||
|
||||
ib2int :: Get Int
|
||||
ib2int = fromMaybe (-1) . readMaybe . LBS8.unpack <$> getLazyByteStringNul
|
||||
|
||||
ib2f :: Get Float
|
||||
ib2f = fromMaybe (-1) . readMaybe . LBS8.unpack <$> getLazyByteStringNul
|
||||
|
||||
ib2txt :: Get Text
|
||||
ib2txt = decodeUtf8 . LBS.toStrict <$> getLazyByteStringNul
|
||||
16
src/Import.hs
Normal file
16
src/Import.hs
Normal file
@ -0,0 +1,16 @@
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
module Import
|
||||
( module RIO
|
||||
, module Types
|
||||
, module Data.Aeson
|
||||
, module Data.Default
|
||||
, module Text.Show.Pretty
|
||||
, module IBClient.Types
|
||||
) where
|
||||
|
||||
import RIO
|
||||
import Types
|
||||
import Data.Aeson (FromJSON, ToJSON)
|
||||
import Data.Default
|
||||
import Text.Show.Pretty
|
||||
import IBClient.Types
|
||||
230
src/Run.hs
Normal file
230
src/Run.hs
Normal file
@ -0,0 +1,230 @@
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
module Run (run) where
|
||||
|
||||
import Import
|
||||
import Chart
|
||||
import Types
|
||||
import Control.Concurrent
|
||||
import Data.Aeson (encodeFile)
|
||||
import Data.Bits
|
||||
import Data.FingerTree (ViewL(..), ViewR(..), viewl, viewr, split, FingerTree)
|
||||
import DearImGui
|
||||
import DearImGui.OpenGL3
|
||||
import DearImGui.GLFW
|
||||
import Graphics.GL
|
||||
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
|
||||
|
||||
import IBClient.Connection
|
||||
|
||||
run :: RIO App ()
|
||||
run = do
|
||||
-- set up IB connection & start threads feeding stuff
|
||||
|
||||
renderLoop
|
||||
|
||||
-- close connections to IB
|
||||
|
||||
renderLoop :: RIO App ()
|
||||
renderLoop = do
|
||||
win <- appWindow <$> ask
|
||||
|
||||
liftIO GLFW.pollEvents
|
||||
close <- liftIO $ GLFW.windowShouldClose win
|
||||
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'
|
||||
else do
|
||||
refs' <- appRefs <$> ask
|
||||
data' <- appData <$> ask
|
||||
selectedAccount <- readTVarIO $ currentAccount refs'
|
||||
let sendQ = twsConnectionSend $ twsConnectionRefs refs'
|
||||
-- Tell ImGui we're starting a new frame
|
||||
liftIO $ do
|
||||
openGL3NewFrame
|
||||
glfwNewFrame
|
||||
newFrame
|
||||
|
||||
|
||||
-- Menu bar
|
||||
withMainMenuBarOpen $ do
|
||||
withMenuOpen "File" $ do
|
||||
menuItem "Quit" >>= \case
|
||||
False -> return ()
|
||||
True -> liftIO $ GLFW.setWindowShouldClose win True
|
||||
let cr = twsConnectionRefs refs'
|
||||
accs <- fmap HM.keys $ liftIO $ readTVarIO $ Types.accounts data'
|
||||
withComboOpen "Account" (maybe "Select account" T.unpack selectedAccount) $ do
|
||||
forM_ accs $ \a -> do
|
||||
selectable (T.unpack a) >>= \case
|
||||
False -> return ()
|
||||
True -> do
|
||||
-- cancel subscription of old account (if any)
|
||||
readTVarIO (currentAccount refs') >>= \case
|
||||
Nothing -> return ()
|
||||
Just aid -> liftIO $ atomically $ writeTQueue sendQ $ Msg_IB_OUT $ IB_RequestAccountData False aid
|
||||
-- subscribe to new account
|
||||
liftIO $ atomically $ writeTQueue sendQ $ Msg_IB_OUT $ IB_RequestAccountData True a
|
||||
-- finally change
|
||||
liftIO $ atomically $ modifyTVar' (currentAccount refs') (const $ Just a)
|
||||
let cStatus = twsConnectionStatus cr
|
||||
connHost <- liftIO $ readTVarIO $ twsConnectionRefsHost cr
|
||||
connPort <- liftIO $ readTVarIO $ twsConnectionRefsPort cr
|
||||
connStatus <- liftIO $ readTVarIO cStatus
|
||||
when (connStatus == TWSDisconnected) $ button "Connect" >>= \case
|
||||
False -> return ()
|
||||
True -> do
|
||||
if connStatus == TWSDisconnected then do
|
||||
logDebug $ display ("Connecting to TWS on " <> T.pack connHost <> ":" <> T.pack 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)
|
||||
textColored (InjetiveGettable cStatus :: InjetiveGettable TWSConnectionStatus ImVec4) cStatusText
|
||||
|
||||
|
||||
bracket_ (begin "TWS-Connection") end $ do
|
||||
let cr = twsConnectionRefs refs'
|
||||
let cStatus = twsConnectionStatus cr
|
||||
let cHost = twsConnectionRefsHost cr
|
||||
let cPort = twsConnectionRefsPort cr
|
||||
void $ inputText "Host" cHost 255
|
||||
void $ inputText "Port" cPort 255
|
||||
button "Connect" >>= \case
|
||||
False -> return ()
|
||||
True -> do
|
||||
connStatus <- liftIO $ readTVarIO cStatus
|
||||
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)
|
||||
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)
|
||||
textColored (InjetiveGettable cStatus :: InjetiveGettable TWSConnectionStatus ImVec4) cStatusText
|
||||
|
||||
bracket_ (begin "Portfolio") end $ do
|
||||
readTVarIO (currentAccount refs') >>= \case
|
||||
Nothing -> text "No account selected"
|
||||
Just aid -> do
|
||||
accs <- liftIO $ readTVarIO $ Types.accounts data'
|
||||
withTable defTableOptions "Portfolio" 6 $ \case
|
||||
False -> return ()
|
||||
True -> do
|
||||
tableSetupColumn "Symbol"
|
||||
tableSetupColumn "Position"
|
||||
tableSetupColumn "Unrealized Profit"
|
||||
tableSetupColumn "Realized Profit"
|
||||
tableSetupColumn "AVG"
|
||||
tableSetupColumn "Market Value"
|
||||
tableHeadersRow
|
||||
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)
|
||||
|
||||
bracket_ (begin "Search Symbols") end $ do
|
||||
readTVarIO (currentAccount refs') >>= \case
|
||||
Nothing -> text "No account selected"
|
||||
Just _ -> do
|
||||
let nextIDVar = nextValidID data'
|
||||
sLookup = nextSymbolLookup data'
|
||||
readTVarIO nextIDVar >>= \case
|
||||
Nothing -> text "no id available, waiting ..."
|
||||
Just i -> do
|
||||
void $ inputText "Symbol-Lookup" (InjetiveGettable @Text @String sLookup) 255
|
||||
button "Lookup" >>= \case
|
||||
False -> return ()
|
||||
True ->
|
||||
liftIO $ atomically $ do
|
||||
readTVar sLookup >>= writeTQueue sendQ . Msg_IB_OUT . IB_RequestMatchingSymbol i
|
||||
modifyTVar' nextIDVar (const Nothing)
|
||||
withTable (defTableOptions { tableFlags = ImGuiTableFlags_SortMulti .|. ImGuiTableFlags_Sortable}) "Symbol" 5 $ \case
|
||||
False -> return ()
|
||||
True -> do
|
||||
tableSetupColumn "Symbol"
|
||||
tableSetupColumn "Security type"
|
||||
tableSetupColumn "Primary exchange"
|
||||
tableSetupColumn "Currency"
|
||||
tableSetupColumn "Available derivatives"
|
||||
withSortableTable $ \(mustSort, sortSpecs) -> do
|
||||
when mustSort $ liftIO $ pPrint sortSpecs
|
||||
tableHeadersRow
|
||||
lResult <- readTVarIO $ symbolLookupResults data'
|
||||
forM_ lResult $ \contract@IBSymbolSample{..} -> do
|
||||
let popupName = "SymbolAction"<>show _symbolId
|
||||
withPopup popupName $ \isPopupOpen -> do
|
||||
when isPopupOpen $ do
|
||||
button "creatChart" >>= \case
|
||||
False -> return ()
|
||||
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
|
||||
tableNextRow
|
||||
whenM tableNextColumn $ do
|
||||
void $ selectableWith (defSelectableOptions { flags = ImGuiSelectableFlags_SpanAllColumns }) (T.unpack _symbol)
|
||||
openPopupOnItemClick popupName ImGuiPopupFlags_MouseButtonRight
|
||||
printDatum _secType
|
||||
printDatum _primaryExchange
|
||||
printDatum _currency
|
||||
printDatum $ T.intercalate ", " _derivatives
|
||||
|
||||
-- chart windows
|
||||
charts <- liftIO . readTVarIO . appCharts $ refs'
|
||||
forM_ (HM.toList charts) $ \(symbol, cVar) -> do
|
||||
bracket_ (begin (T.unpack 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
|
||||
return ()
|
||||
|
||||
|
||||
-- Show the ImGui demo window
|
||||
showDemoWindow
|
||||
|
||||
-- Show the ImPlot demo window
|
||||
--showPlotDemoWindow
|
||||
|
||||
-- Render
|
||||
liftIO $ glClear GL_COLOR_BUFFER_BIT
|
||||
|
||||
render
|
||||
liftIO $ openGL3RenderDrawData =<< getDrawData
|
||||
|
||||
liftIO $ GLFW.swapBuffers win
|
||||
|
||||
renderLoop
|
||||
240
src/Types.hs
Normal file
240
src/Types.hs
Normal file
@ -0,0 +1,240 @@
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE DerivingVia #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# LANGUAGE QuantifiedConstraints #-}
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
module Types where
|
||||
|
||||
import Data.Aeson hiding (Options)
|
||||
import Data.Default
|
||||
import Data.StateVar
|
||||
import Data.Types.Injective
|
||||
import Data.Time
|
||||
import Data.FingerTree
|
||||
import Data.Semigroup
|
||||
import GHC.Generics
|
||||
import Graphics.UI.GLFW (Window)
|
||||
import DearImGui
|
||||
import RIO
|
||||
import RIO.Process
|
||||
import Lens.Micro.TH
|
||||
import qualified Data.Text as T
|
||||
|
||||
import IBClient.Types
|
||||
|
||||
-- | Command line arguments
|
||||
data Options = Options
|
||||
{ optionsVerbose :: !Bool
|
||||
}
|
||||
|
||||
data WindowParams = WindowParams
|
||||
{ _windowHeight :: Int
|
||||
, _windowWidth :: Int
|
||||
} deriving (Show, Generic, FromJSON, ToJSON)
|
||||
|
||||
instance Default WindowParams where
|
||||
def = WindowParams 1024 768
|
||||
|
||||
data TWSConnection = TWSConnection
|
||||
{ _host :: Text
|
||||
, _port :: Text
|
||||
} deriving (Show, Generic, FromJSON, ToJSON)
|
||||
|
||||
instance Default TWSConnection where
|
||||
def = TWSConnection "127.0.0.1" "7497"
|
||||
|
||||
instance FromJSON LogLevel where
|
||||
parseJSON = withText "LogLevel" $ \case
|
||||
"LevelDebug" -> return LevelDebug
|
||||
"LevelInfo" -> return LevelInfo
|
||||
"LevelWarn" -> return LevelWarn
|
||||
"LevelError" -> return LevelError
|
||||
x -> fail $ T.unpack $ "encountered "<>x
|
||||
|
||||
instance ToJSON LogLevel where
|
||||
toJSON LevelDebug = String "LevelDebug"
|
||||
toJSON LevelInfo = String "LevelInfo"
|
||||
toJSON LevelWarn = String "LevelWarn"
|
||||
toJSON LevelError = String "LevelError"
|
||||
toJSON (LevelOther _) = String "LevelDebug"
|
||||
|
||||
data Settings = Settings
|
||||
{ _windowParams :: WindowParams
|
||||
, _twsConnection :: TWSConnection
|
||||
, _logLevel :: LogLevel
|
||||
} deriving (Show, Generic, FromJSON, ToJSON)
|
||||
|
||||
makeLenses ''WindowParams
|
||||
makeLenses ''TWSConnection
|
||||
makeLenses ''Settings
|
||||
|
||||
instance Default Settings where
|
||||
def = Settings def def LevelWarn
|
||||
|
||||
data TWSConnectionStatus = TWSDisconnected
|
||||
| TWSConnecting
|
||||
| TWSConnected
|
||||
deriving (Show, Eq, Enum, Bounded)
|
||||
|
||||
data TWSConnectionRefs = TWSConnectionRefs
|
||||
{ twsConnectionRefsHost :: TVar String
|
||||
, twsConnectionRefsPort :: TVar String
|
||||
, twsConnectionStatus :: TVar TWSConnectionStatus
|
||||
, twsConnectionSend :: TQueue Msg_IB_OUT
|
||||
, twsConnectionRecieve :: TQueue Msg_IB_IN
|
||||
}
|
||||
|
||||
instance Injective TWSConnectionStatus ImVec4 where
|
||||
to = \case
|
||||
TWSDisconnected -> ImVec4 1 0 0 1
|
||||
TWSConnecting -> ImVec4 1 1 0 1
|
||||
TWSConnected -> ImVec4 0 1 0 1
|
||||
|
||||
instance Injective TWSConnectionStatus String where
|
||||
to = \case
|
||||
TWSDisconnected -> "Not Connected"
|
||||
TWSConnecting -> "Trying to connect..."
|
||||
TWSConnected -> "Connected"
|
||||
|
||||
data DataRefs = DataRefs
|
||||
{ accounts :: TVar (HashMap Text IBAccount)
|
||||
, nextValidID :: TVar (Maybe Int)
|
||||
, nextSymbolLookup :: TVar Text
|
||||
, symbolLookupResults :: TVar [IBSymbolSample]
|
||||
}
|
||||
mkIBAccount :: Text -> IBAccount
|
||||
mkIBAccount u = IBAccount (IBAccountInfo u mempty mempty) mempty mempty
|
||||
|
||||
data IBAccount = IBAccount
|
||||
{ _accountInfo :: IBAccountInfo
|
||||
, _accountPortfolio :: [IBPortfolioValue]
|
||||
, _accountStrategies :: [IBAccountStrategy]
|
||||
} deriving (Show, Eq)
|
||||
|
||||
|
||||
data IBAccountInfo = IBAccountInfo
|
||||
{ _accountName :: Text
|
||||
, _accountProperties :: HashMap Text [(Text, Text)] -- (value, currency)
|
||||
, _accountLastUpdate :: Text
|
||||
} deriving (Show, Eq)
|
||||
|
||||
data IBPortfolioValue = IBPortfolioValue
|
||||
{ _contract :: IBContract
|
||||
, _position :: Float
|
||||
, _marketPrice :: Float
|
||||
, _marketValue :: Float
|
||||
, _averageCost :: Float
|
||||
, _unrealizedPNL :: Float
|
||||
, _realizedPNL :: Float
|
||||
} deriving (Show, Eq)
|
||||
|
||||
newtype IBAccountStrategy = IBAccountStrategy [Int] -- Int -> contract-id for this strategy
|
||||
deriving (Show, Eq)
|
||||
|
||||
data IBSymbolSample = IBSymbolSample
|
||||
{ _symbolId :: Int
|
||||
, _symbol :: Text
|
||||
, _secType :: Text
|
||||
, _primaryExchange :: Text
|
||||
, _currency :: Text
|
||||
, _derivatives :: [Text]
|
||||
} deriving (Show, Eq)
|
||||
|
||||
makeLenses ''IBAccountStrategy
|
||||
makeLenses ''IBAccountInfo
|
||||
makeLenses ''IBAccount
|
||||
|
||||
data ChartSettings = ChartSettings
|
||||
{ chartResolution :: Int
|
||||
, chartStart :: Maybe UTCTime
|
||||
, chartEnd :: Maybe UTCTime
|
||||
} deriving (Show, Eq)
|
||||
|
||||
defChartSettings :: ChartSettings
|
||||
defChartSettings = ChartSettings 60 Nothing Nothing
|
||||
|
||||
-- data TimeWindow = TimeWindow
|
||||
-- { begin :: Int
|
||||
-- , end :: Int
|
||||
-- } deriving (Show, Eq)
|
||||
--
|
||||
-- instance Semigroup TimeWindow where
|
||||
-- (TimeWindow a b) <> (TimeWindow x y) = TimeWindow (min a x) (max b y)
|
||||
--
|
||||
-- instance Monoid TimeWindow where
|
||||
-- mempty = TimeWindow 0 86400
|
||||
|
||||
newtype TimePoint = TimePoint Int
|
||||
deriving Eq
|
||||
deriving newtype Show
|
||||
deriving (Semigroup, Monoid) via (Max Int)
|
||||
|
||||
data ChartStudies = SMA { window :: Int, value :: Float }
|
||||
| OLHC { olhc_open :: Float, olhc_low :: Float, olhc_high :: Float, olhc_close :: Float}
|
||||
deriving (Show, Eq)
|
||||
|
||||
data ChartPoint = ChartPoint
|
||||
{ timeOfDay :: TimePoint
|
||||
, pointValue :: Float
|
||||
, pointExtra :: [ChartStudies]
|
||||
} deriving (Show, Eq)
|
||||
|
||||
instance Measured TimePoint ChartPoint where
|
||||
measure = timeOfDay
|
||||
|
||||
data Chart = Chart
|
||||
{ chartData :: FingerTree TimePoint ChartPoint
|
||||
, chartHistData :: HashMap Day (FingerTree TimePoint ChartPoint)
|
||||
, fillerThread :: ThreadId
|
||||
, chartSettings :: ChartSettings
|
||||
, chartCache :: [ChartPoint]
|
||||
, lastCacheUpdate :: Maybe TimePoint
|
||||
, chartDirty :: Bool
|
||||
} deriving (Show, Eq)
|
||||
|
||||
newtype InjetiveGettable a b = InjetiveGettable
|
||||
{ gettable :: TVar a
|
||||
}
|
||||
|
||||
instance (Injective a b) => HasGetter (InjetiveGettable a b) b where
|
||||
get r = liftIO $ do
|
||||
(value :: a) <- get (gettable r)
|
||||
return $ Data.Types.Injective.to value
|
||||
|
||||
instance (Injective b a) => HasSetter (InjetiveGettable a b) b where
|
||||
t $= a = liftIO $ do
|
||||
let b = Data.Types.Injective.to a
|
||||
gettable t $= b
|
||||
|
||||
newtype DefaultJSON a = DefaultJSON { unDefaultJSON :: a }
|
||||
|
||||
instance (FromJSON a, Default a) => FromJSON (DefaultJSON a) where
|
||||
parseJSON v = DefaultJSON <$> (parseJSON v <|> pure def)
|
||||
|
||||
data AppRefs = AppRefs
|
||||
{ twsConnectionRefs :: TWSConnectionRefs
|
||||
, currentAccount :: TVar (Maybe Text)
|
||||
, appCharts :: TVar (HashMap Text (TVar Chart))
|
||||
, tickerIdToSymbol :: TVar (HashMap Int Text)
|
||||
}
|
||||
|
||||
data App = App
|
||||
{ appSettings :: !Settings
|
||||
, appLogFunc :: !LogFunc
|
||||
, appProcessContext :: !ProcessContext
|
||||
, appOptions :: !Options
|
||||
, appWindow :: !Window
|
||||
, appRefs :: !AppRefs
|
||||
, appData :: !DataRefs
|
||||
-- Add other app-specific configuration information here
|
||||
}
|
||||
|
||||
instance HasLogFunc App where
|
||||
logFuncL = lens appLogFunc (\x y -> x { appLogFunc = y })
|
||||
instance HasProcessContext App where
|
||||
processContextL = lens appProcessContext (\x y -> x { appProcessContext = y })
|
||||
11
src/Util.hs
Normal file
11
src/Util.hs
Normal file
@ -0,0 +1,11 @@
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
-- | Silly utility module, used to demonstrate how to write a test
|
||||
-- case.
|
||||
module Util
|
||||
( plus2
|
||||
) where
|
||||
|
||||
import RIO
|
||||
|
||||
plus2 :: Int -> Int
|
||||
plus2 = (+ 2)
|
||||
79
stack.yaml
Normal file
79
stack.yaml
Normal file
@ -0,0 +1,79 @@
|
||||
# This file was automatically generated by 'stack init'
|
||||
#
|
||||
# Some commonly used options have been documented as comments in this file.
|
||||
# For advanced use and comprehensive documentation of the format, please see:
|
||||
# https://docs.haskellstack.org/en/stable/yaml_configuration/
|
||||
|
||||
# Resolver to choose a 'specific' stackage snapshot or a compiler version.
|
||||
# A snapshot resolver dictates the compiler version and the set of packages
|
||||
# to be used for project dependencies. For example:
|
||||
#
|
||||
# resolver: lts-3.5
|
||||
# resolver: nightly-2015-09-21
|
||||
# resolver: ghc-7.10.2
|
||||
#
|
||||
# The location of a snapshot can be provided as a file or url. Stack assumes
|
||||
# a snapshot provided as a file might change, whereas a url resource does not.
|
||||
#
|
||||
# resolver: ./custom-snapshot.yaml
|
||||
# resolver: https://example.com/snapshots/2018-01-01.yaml
|
||||
resolver: lts-18.24
|
||||
|
||||
# User packages to be built.
|
||||
# Various formats can be used as shown in the example below.
|
||||
#
|
||||
# packages:
|
||||
# - some-directory
|
||||
# - https://example.com/foo/bar/baz-0.0.2.tar.gz
|
||||
# subdirs:
|
||||
# - auto-update
|
||||
# - wai
|
||||
packages:
|
||||
- .
|
||||
- deps/dear-imgui.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:
|
||||
#
|
||||
# extra-deps:
|
||||
# - acme-missiles-0.3
|
||||
# - git: https://github.com/commercialhaskell/stack.git
|
||||
# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
|
||||
#
|
||||
extra-deps:
|
||||
- type-iso-1.0.1.0@sha256:75682a06a5af1798c6641ba3cc175685a1f699962ad22ab194a487c0d6b7da66,1892
|
||||
- numericpeano-0.2.0.0@sha256:e3a1dc960817a81f39d276e7bfa0124e8efa1b91b5c272a70dfa16c38627f172,1406
|
||||
|
||||
allow-newer: true
|
||||
|
||||
# Override default flag values for local packages and extra-deps
|
||||
flags:
|
||||
dear-imgui:
|
||||
# libraries
|
||||
glfw: true
|
||||
sdl: false
|
||||
vulkan: false
|
||||
# hardware-requirements
|
||||
opengl3: true
|
||||
opengl2: false
|
||||
|
||||
# Extra package databases containing global packages
|
||||
# extra-package-dbs: []
|
||||
|
||||
# Control whether we use the GHC we find on the path
|
||||
# system-ghc: true
|
||||
#
|
||||
# Require a specific version of stack, using version ranges
|
||||
# require-stack-version: -any # Default
|
||||
# require-stack-version: ">=2.7"
|
||||
#
|
||||
# Override the architecture used by stack, especially useful on Windows
|
||||
# arch: i386
|
||||
# arch: x86_64
|
||||
#
|
||||
# Extra directories used by stack for building
|
||||
# extra-include-dirs: [/path/to/dir]
|
||||
# extra-lib-dirs: [/path/to/dir]
|
||||
#
|
||||
# Allow a newer minor version of GHC than the snapshot specifies
|
||||
# compiler-check: newer-minor
|
||||
1
test/Spec.hs
Normal file
1
test/Spec.hs
Normal file
@ -0,0 +1 @@
|
||||
{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
|
||||
14
test/UtilSpec.hs
Normal file
14
test/UtilSpec.hs
Normal file
@ -0,0 +1,14 @@
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
module UtilSpec (spec) where
|
||||
|
||||
import Import
|
||||
import Util
|
||||
import Test.Hspec
|
||||
import Test.Hspec.QuickCheck
|
||||
|
||||
spec :: Spec
|
||||
spec = do
|
||||
describe "plus2" $ do
|
||||
it "basic check" $ plus2 0 `shouldBe` 2
|
||||
it "overflow" $ plus2 maxBound `shouldBe` minBound + 1
|
||||
prop "minus 2" $ \i -> plus2 i - 2 `shouldBe` i
|
||||
Loading…
Reference in New Issue
Block a user