diff --git a/app/Main.hs b/app/Main.hs index 5b0feab..8d490ed 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -5,9 +5,10 @@ import QuoteSource.DDE import QuoteSource.DataImport import Control.Concurrent import Control.Monad +import Control.Monad.IO.Class +import Data.IORef +import Graphics.UI.Gtk hiding (Action, backspace) -import Graphics.UI.FLTK.LowLevel.FL -import Graphics.UI.FLTK.LowLevel.FLTKHS callback :: DdeCallback callback = undefined @@ -15,11 +16,11 @@ callback = undefined main :: IO () main = do dis <- initDataImportServer "atrade" - forever $ threadDelay 1000 - window <- windowNew (Size (Width 320) (Height 170)) - Nothing Nothing - end window - showWidget window - _ <- run - return () + void initGUI + window <- windowNew + window `on` deleteEvent $ do + liftIO mainQuit + return False + widgetShowAll window + mainGUI diff --git a/quik-connector.cabal b/quik-connector.cabal index 14d745b..1784780 100644 --- a/quik-connector.cabal +++ b/quik-connector.cabal @@ -20,7 +20,9 @@ library , QuoteSource.DataImport build-depends: base >= 4.7 && < 5 , Win32 - , fltkhs + , gtk + , binary + , bytestring default-language: Haskell2010 extra-libraries: "user32" @@ -31,6 +33,7 @@ executable quik-connector-exe build-depends: base , quik-connector , Win32 + , gtk default-language: Haskell2010 extra-libraries: "user32" diff --git a/src/QuoteSource/DDE.hs b/src/QuoteSource/DDE.hs index 389a043..a268ce4 100644 --- a/src/QuoteSource/DDE.hs +++ b/src/QuoteSource/DDE.hs @@ -19,11 +19,13 @@ import Control.Exception import Control.Monad import Data.Bits import Data.Typeable +import Data.ByteString hiding (map) import System.Win32.DLL import System.Win32.Types import Foreign import Foreign.C.Types import Foreign.C.String +import Foreign.Marshal.Array data DdeException = ApiError String deriving (Show, Typeable) @@ -47,28 +49,34 @@ ddeCpWinAnsi = 1004 instance Exception DdeException -foreign import stdcall unsafe "windows.h DdeInitializeW" +foreign import ccall unsafe "windows.h DdeInitializeW" ddeInitialize :: LPDWORD -> FunPtr DdeCallback -> DWORD -> DWORD -> IO CUInt -foreign import stdcall unsafe "windows.h DdeUninitialize" +foreign import ccall unsafe "windows.h DdeUninitialize" ddeUninitialize :: DWORD -> IO BOOL -foreign import stdcall unsafe "windows.h DdeCreateStringHandleW" +foreign import ccall unsafe "windows.h DdeCreateStringHandleW" ddeCreateStringHandle :: DWORD -> LPSTR -> CInt -> IO HANDLE -foreign import stdcall unsafe "windows.h DdeFreeStringHandleW" +foreign import ccall unsafe "windows.h DdeFreeStringHandleW" ddeFreeStringHandle :: DWORD -> LPSTR -> IO HANDLE -foreign import stdcall unsafe "windows.h DdeNameService" +foreign import ccall unsafe "windows.h DdeNameService" ddeNameService :: DWORD -> HANDLE -> HANDLE -> CInt -> IO HANDLE -foreign import stdcall unsafe "windows.h DdeCmpStringHandles" +foreign import ccall unsafe "windows.h DdeCmpStringHandles" ddeCmpStringHandles :: HANDLE -> HANDLE -> IO CInt -foreign import stdcall unsafe "windows.h DdeQueryStringW" +foreign import ccall unsafe "windows.h DdeQueryStringW" ddeQueryString :: DWORD -> HANDLE -> CString -> DWORD -> CInt -> IO DWORD -foreign import stdcall "wrapper" +foreign import ccall unsafe "windows.h DdeAccessData" + ddeAccessData :: HANDLE -> LPDWORD -> IO (Ptr CUChar) + +foreign import ccall unsafe "windows.h DdeUnaccessData" + ddeUnaccessData :: HANDLE -> IO () + +foreign import ccall "wrapper" mkCallbackPtr :: DdeCallback -> IO (FunPtr DdeCallback) data DdeState = DdeState { @@ -90,8 +98,8 @@ initializeDde appName topicName callback = alloca (\instancePtr -> do when (rc /= CUInt 0) $ throw $ ApiError "Unable to initialize DDE" withCString appName (\appNameRaw -> withCString topicName (\topicNameRaw -> do - appNameHandle <- ddeCreateStringHandle instanceRaw appNameRaw 0 - topicNameHandle <- ddeCreateStringHandle instanceRaw topicNameRaw 0 + appNameHandle <- ddeCreateStringHandle instanceRaw appNameRaw ddeCpWinAnsi + topicNameHandle <- ddeCreateStringHandle instanceRaw topicNameRaw ddeCpWinAnsi when (appNameHandle == nullHANDLE || topicNameHandle == nullHANDLE) $ throw $ ApiError "Unable to create strings handles" rc2 <- ddeNameService instanceRaw appNameHandle nullPtr 1 @@ -112,3 +120,10 @@ queryString state maxSize handle = allocaBytes maxSize (\x -> do then return Nothing else Just <$> peekCAString x) +accessData :: HANDLE -> IO ByteString +accessData handle = alloca (\dataSizePtr -> do + dataPtr <- ddeAccessData handle dataSizePtr + dataSize <- peek dataSizePtr + pack . (map (toEnum . fromEnum)) <$> peekArray (fromEnum dataSize) dataPtr) + + diff --git a/src/QuoteSource/DataImport.hs b/src/QuoteSource/DataImport.hs index 496354b..7bb9a8a 100644 --- a/src/QuoteSource/DataImport.hs +++ b/src/QuoteSource/DataImport.hs @@ -13,7 +13,10 @@ import Foreign.C.Types import Foreign.C.String import QuoteSource.DDE +import QuoteSource.XlParser import Data.IORef +import Text.Printf +import Data.Binary data ServerState = ServerState { dde :: DdeState, @@ -21,22 +24,17 @@ data ServerState = ServerState { } ddeCallback :: IORef ServerState -> CUInt -> CUInt -> HANDLE -> HANDLE -> HANDLE -> HANDLE -> LPDWORD -> LPDWORD -> IO HANDLE -ddeCallback state msgType format hConv hsz1 hsz2 hData dwData1 dwData2 = do - putStrLn "Callback" - return nullHANDLE - -{- +ddeCallback state msgType format hConv hsz1 hsz2 hData dwData1 dwData2 | msgType == ddeXtypConnect = handleConnect state hsz1 hsz2 | msgType == ddeXtypPoke = handlePoke state hsz1 hData | otherwise = do - print msgType + putStrLn $ printf "msgtype: %08x" $ toInteger msgType return nullHANDLE where handleConnect state hsz1 hsz2 = do myAppName <- appName <$> readIORef state myDdeState <- dde <$> readIORef state maybeAppName <- queryString myDdeState 256 hsz2 - putStrLn "Connect" case maybeAppName of Just incomingAppName -> do putStrLn incomingAppName @@ -46,10 +44,10 @@ ddeCallback state msgType format hConv hsz1 hsz2 hData dwData1 dwData2 = do Nothing -> return ddeResultFalse handlePoke state hsz1 hData = do - putStrLn "Poke" - return ddeResultAck - -} - + myDdeState <- dde <$> readIORef state + maybeTopic <- queryString myDdeState 256 hsz1 + case maybeTopic of + Nothing -> return ddeResultFalse initDataImportServer :: String -> IO (IORef ServerState) initDataImportServer applicationName = do diff --git a/src/QuoteSource/TableParser.hs b/src/QuoteSource/TableParser.hs new file mode 100644 index 0000000..224ea3b --- /dev/null +++ b/src/QuoteSource/TableParser.hs @@ -0,0 +1,4 @@ + +module QuoteSource.TableParser ( +) where + diff --git a/src/QuoteSource/XlParser.hs b/src/QuoteSource/XlParser.hs new file mode 100644 index 0000000..7f025b0 --- /dev/null +++ b/src/QuoteSource/XlParser.hs @@ -0,0 +1,39 @@ + +module QuoteSource.XlParser ( + XlData(..), + xlParser +) where + +import Control.Applicative +import Control.Monad +import Data.Binary.Get +import Data.ByteString + +data XlData = XlInt Int | XlDouble Double | XlString String | XlEmpty + +data XlPosition = XlPosition { width :: Int, height :: Int, xPos :: Int, yPos :: Int } + +btTable = 16 +btFloat = 1 +btString = 2 +btBlank = 5 +btInt = 6 +btSkip = 7 + +incrementPosition :: XlPosition -> Maybe XlPosition +incrementPosition pos = do + if 1 + xPos pos < width pos + then Just pos { xPos = 1 + xPos pos } + else if 1 + yPos pos < height pos + then Just pos { xPos = 0, yPos = 1 + yPos pos } + else Nothing + +xlParser :: Get (Int, Int, [XlData]) +xlParser = do + datatype <- getWord16le + when (datatype /= btTable) $ fail "First entry should be table" + blocksize <- fromEnum <$> getWord16le + when (blocksize /= 4) $ fail "Table entry should have size 4" + return (0, 0, []) + +