{-# LANGUAGE ForeignFunctionInterface #-} module System.Win32.Comm where import System.IO import System.Win32.Types import Data.Word import Foreign.Storable import Foreign.Ptr 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 type LPDCB = Ptr DCB data DCB = DCB { baudRate :: BaudRate, parity :: Parity, stopBits :: StopBits, flowControl :: FlowControl, byteSize :: Word8 } deriving Show -- If this member is TRUE, binary mode is enabled. Windows does not support nonbinary mode transfers, so this member must be TRUE. fBinary :: DWORD fBinary = 0x0000000000000001 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 (fBinary :: 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 _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 _byteSize <- (#peek DCB, ByteSize) buf :: IO BYTE _parity <- do _par <- (#peek DCB, Parity) buf :: IO BYTE case _par of 0 -> return NoParity 1 -> return Odd 2 -> return Even --3 -> markparity --4 -> spaceparity _ -> 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 _XoffLim <- (#peek DCB, XoffLim) buf :: IO WORD return DCB { baudRate = _baudRate, parity = _parity, stopBits = _stopBits, flowControl = NoFlowControl, byteSize = _byteSize } getCommState :: HANDLE -> IO DCB getCommState h = alloca (\dcbp -> do c_GetCommState h dcbp peek dcbp ) --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 (c_SetCommState h) 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 = alloca (\c -> do c_GetCommTimeouts h c peek c ) -- 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 (c_SetCommTimeouts h) return () -- setcommtimeouts -- winbase.h -> BOOL WINAPI SetCommTimeouts(HANDLE, LPCOMMTIMEOUTS); foreign import stdcall unsafe "winbase.h SetCommTimeouts" c_SetCommTimeouts :: HANDLE -> LPCOMMTIMEOUTS -> IO BOOL