{-# LANGUAGE ForeignFunctionInterface #-} module System.Win32.Comm where import System.IO import System.Win32.File import System.Win32.Types import Data.Bits import Data.Word import Foreign.Storable import Foreign.Ptr import Foreign.C.Types import Foreign.C.String import Foreign.Marshal.Alloc import Foreign.Marshal.Utils #include data BaudRate = B0 | B50 | B75 | B110 | B134 | B150 | B200 | B300 | B600 | B1200 | B1800 | B2400 | B4800 | B9600 | B19200 | B38400 | B57600 | B115200 deriving Show data StopBits = One | Two deriving Show data Parity = Even | Odd | NoParity deriving Show data FlowControl = Software | NoFlowControl deriving Show --typedef struct _DCB { -- DWORD DCBlength; -- DWORD BaudRate; -- DWORD fBinary :1; If this member is TRUE, binary mode is enabled. Windows does not support nonbinary mode transfers, so this member must be TRUE -- DWORD fParity :1; If this member is TRUE, parity checking is performed and errors are reported -- DWORD fOutxCtsFlow :1; -- DWORD fOutxDsrFlow :1; -- DWORD fDtrControl :2; -- DWORD fDsrSensitivity :1; -- DWORD fTXContinueOnXoff :1; -- DWORD fOutX :1; -- DWORD fInX :1; -- DWORD fErrorChar :1; -- DWORD fNull :1; -- DWORD fRtsControl :2; -- DWORD fAbortOnError :1; -- DWORD fDummy2 :17; Reserved; do not use. -- WORD wReserved; Reserved; must be zero. -- WORD XonLim; -- WORD XoffLim; -- BYTE ByteSize; -- BYTE Parity; -- BYTE StopBits; -- char XonChar; The value of the XON character for both transmission and reception. -- char XoffChar; The value of the XOFF character for both transmission and reception. -- char ErrorChar; The value of the character used to replace bytes received with a parity error. -- char EofChar; The value of the character used to signal the end of data. -- char EvtChar; The value of the character used to signal an event. -- WORD wReserved1; Reserved; do not use. --}DCB, *LPDCB; type LPDCB = Ptr DCB data DCB = DCB { baudRate :: BaudRate, parity :: Parity, stopBits :: StopBits, flowControl :: FlowControl, byteSize :: Word8 } deriving Show instance Storable DCB where sizeOf = const #size DCB alignment = sizeOf poke buf dcb = do (#poke DCB, DCBlength) buf (sizeOf dcb) (#poke DCB, BaudRate) buf ((case (baudRate dcb) of B0 -> 0 B50 -> 50 B75 -> 75 B110 -> 110 B134 -> 134 B150 -> 150 B200 -> 200 B300 -> 300 B600 -> 600 B1200 -> 1200 B1800 -> 1800 B2400 -> 2400 B4800 -> 4800 B9600 -> 9600 B19200 -> 19200 B38400 -> 38400 B57600 -> 57600 B115200 -> 115200) :: DWORD) pokeByteOff buf 8 (0x0000000000000001 :: DWORD) (#poke DCB, wReserved) buf (0 :: WORD) (#poke DCB, XonLim) buf (2048 :: WORD) (#poke DCB, XoffLim) buf (512 :: WORD) (#poke DCB, ByteSize) buf (byteSize dcb :: BYTE) (#poke DCB, Parity) buf (case (parity dcb) of NoParity -> 0 Odd -> 1 Even -> 2 :: BYTE) (#poke DCB, StopBits) buf (case (stopBits dcb) of One -> 0 Two -> 2 :: BYTE) (#poke DCB, wReserved1) buf (0 :: WORD) peek buf = do _dCBlength <- (#peek DCB, DCBlength) buf :: IO DWORD --print $ "dcblenth=" ++ (show _dCBlength) _baudRate <- do _baud <- (#peek DCB, BaudRate) buf :: IO DWORD case _baud of 0 -> return B0 50 -> return B50 75 -> return B75 110 -> return B110 134 -> return B134 150 -> return B150 200 -> return B200 300 -> return B300 600 -> return B600 1200 -> return B1200 1800 -> return B1800 2400 -> return B2400 4800 -> return B4800 9600 -> return B9600 19200 -> return B19200 38400 -> return B38400 57600 -> return B57600 115200 -> return B115200 _ -> fail "incorrect baudrate" _fsettings <- peekByteOff buf 8 :: IO DWORD -- TODO: use this bitmask --print $ "fsettings:" ++ (show _fsettings ) --print $ "bit 0:" ++ (show (testBit _fsettings 0)) --print $ "bit 1:" ++ (show (testBit _fsettings 1)) --print $ "bit 2:" ++ (show (testBit _fsettings 2)) --print $ "bit 3:" ++ (show (testBit _fsettings 3)) --print $ "bit 4:" ++ (show (testBit _fsettings 4)) --print $ "bit 5:" ++ (show (testBit _fsettings 5)) --print $ "bit 6:" ++ (show (testBit _fsettings 6)) --print $ "bit 7:" ++ (show (testBit _fsettings 7)) --print $ "bit 8:" ++ (show (testBit _fsettings 8)) --print $ "bit 9:" ++ (show (testBit _fsettings 9)) --print $ "bit 10:" ++ (show (testBit _fsettings 10)) --print $ "bit 11:" ++ (show (testBit _fsettings 11)) --print $ "bit 12:" ++ (show (testBit _fsettings 12)) --print $ "bit 31:" ++ (show (testBit _fsettings 31)) _byteSize <- (#peek DCB, ByteSize) buf :: IO BYTE _parity <- do _par <- (#peek DCB, Parity) buf :: IO BYTE -- noparity = 0 -- oddparity = 1 -- evenparity = 2 -- markparity = 3 -- spaceparity = 4 case _par of 0 -> return NoParity 1 -> return Odd 2 -> return Even --3 -> --4 -> _ -> fail $ "incorrect parity" ++ (show _par) _stopBits <- do _stopb <- (#peek DCB, StopBits) buf :: IO BYTE case _stopb of 0 -> return One -- 1 -> one5stopbits 2 -> return Two _ -> fail "unexpected stop bit count" _XonLim <- (#peek DCB, XonLim) buf :: IO WORD --print $ show _XonLim _XoffLim <- (#peek DCB, XoffLim) buf :: IO WORD --print $ show _XoffLim return $ DCB { baudRate = _baudRate, parity = _parity, stopBits = _stopBits, flowControl = NoFlowControl, byteSize = _byteSize } getCommState :: HANDLE -> IO DCB getCommState h = do dcb <- alloca (\dcbp -> do c_GetCommState h dcbp dcb <- peek dcbp return dcb ) return dcb --BOOL WINAPI GetCommState( -- __in HANDLE hFile, -- __inout LPDCB lpDCB --); foreign import stdcall unsafe "winbase.h GetCommState" c_GetCommState :: HANDLE -> LPDCB -> IO BOOL setCommState :: HANDLE -> DCB -> IO () setCommState h dcb = do with dcb (\ pdcb -> c_SetCommState h pdcb ) return () --BOOL WINAPI SetCommState( -- __in HANDLE hFile, -- __in LPDCB lpDCB --); foreign import stdcall unsafe "winbase.h SetCommState" c_SetCommState :: HANDLE -> LPDCB -> IO BOOL type LPCOMMTIMEOUTS = Ptr COMMTIMEOUTS data COMMTIMEOUTS = COMMTIMEOUTS { readIntervalTimeout :: DWORD, -- in milliseconds readTotalTimeoutMultiplier :: DWORD, -- in milliseconds readTotalTimeoutConstant :: DWORD, -- in milliseconds writeTotalTimeoutMultiplier :: DWORD, -- in milliseconds writeTotalTimeoutConstant :: DWORD } -- in milliseconds deriving Show instance Storable COMMTIMEOUTS where sizeOf = const #size COMMTIMEOUTS alignment = sizeOf poke buf ct = do (#poke COMMTIMEOUTS, ReadIntervalTimeout) buf (readIntervalTimeout ct) (#poke COMMTIMEOUTS, ReadTotalTimeoutMultiplier) buf ( readTotalTimeoutMultiplier ct) (#poke COMMTIMEOUTS, ReadTotalTimeoutConstant) buf ( readTotalTimeoutConstant ct) (#poke COMMTIMEOUTS, WriteTotalTimeoutMultiplier) buf ( writeTotalTimeoutMultiplier ct) (#poke COMMTIMEOUTS, WriteTotalTimeoutConstant) buf ( writeTotalTimeoutConstant ct) peek buf = do _readIntervalTimeout <- (#peek COMMTIMEOUTS, ReadIntervalTimeout) buf _readTotalTimeoutMultiplier <- (#peek COMMTIMEOUTS, ReadTotalTimeoutMultiplier ) buf _readTotalTimeoutConstant <- (#peek COMMTIMEOUTS, ReadTotalTimeoutConstant ) buf _writeTotalTimeoutMultiplier <- (#peek COMMTIMEOUTS, WriteTotalTimeoutMultiplier ) buf _writeTotalTimeoutConstant <- (#peek COMMTIMEOUTS, WriteTotalTimeoutConstant ) buf return $ COMMTIMEOUTS { readIntervalTimeout = _readIntervalTimeout, readTotalTimeoutMultiplier = _readTotalTimeoutMultiplier, readTotalTimeoutConstant = _readTotalTimeoutConstant, writeTotalTimeoutMultiplier = _writeTotalTimeoutMultiplier, writeTotalTimeoutConstant = _writeTotalTimeoutConstant } getCommTimeouts :: HANDLE -> IO COMMTIMEOUTS getCommTimeouts h = do comm_timeouts <- alloca (\c -> do c_GetCommTimeouts h c ct <- peek c return ct ) return comm_timeouts -- getcommtimeouts -- winbase.h -> BOOL WINAPI GetCommTimeouts(HANDLE, LPCOMMTIMEOUTS); foreign import stdcall unsafe "winbase.h GetCommTimeouts" c_GetCommTimeouts :: HANDLE -> LPCOMMTIMEOUTS -> IO BOOL setCommTimeouts :: HANDLE -> COMMTIMEOUTS -> IO () setCommTimeouts h ct = do with ct (\ pct -> c_SetCommTimeouts h pct ) return () -- setcommtimeouts -- winbase.h -> BOOL WINAPI SetCommTimeouts(HANDLE, LPCOMMTIMEOUTS); foreign import stdcall unsafe "winbase.h SetCommTimeouts" c_SetCommTimeouts :: HANDLE -> LPCOMMTIMEOUTS -> IO BOOL