{-# LANGUAGE ForeignFunctionInterface #-} module System.Win32.Comm where import System.IO import System.Win32.Types import Data.Word import Data.Bits import Foreign.Storable import Foreign.Ptr import Foreign.Marshal.Alloc import Foreign.Marshal.Utils import qualified System.Hardware.Serialport.Types as STypes #include type LPDCB = Ptr DCB data DCB = DCB { baudRate :: STypes.BaudRate, parity :: STypes.Parity, stopBits :: STypes.StopBits, byteSize :: Word8, flowControl :: STypes.FlowControl } -- | 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 -- | If this member is TRUE, parity checking is performed and errors are reported. fParity :: DWORD fParity = 0x0000000000000010 instance Storable DCB where sizeOf = const #size DCB alignment = sizeOf poke buf dcb = do (#poke DCB, DCBlength) buf (sizeOf dcb) (#poke DCB, BaudRate) buf (fromIntegral (STypes.fromBaudToInt (baudRate dcb)) :: DWORD) pokeByteOff buf 8 (fBinary .|. fParity :: 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 STypes.NoParity -> 0 STypes.Odd -> 1 STypes.Even -> 2 :: BYTE) (#poke DCB, StopBits) buf (case (stopBits dcb) of STypes.One -> 0 STypes.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 return $ STypes.fromIntToBaud (fromIntegral _baud :: Int) _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 STypes.NoParity 1 -> return STypes.Odd 2 -> return STypes.Even 3 -> fail $ "unsupported markparity" 4 -> fail $ "unsupported spaceparity" _ -> fail $ "unsupported parity" ++ (show _par) _stopBits <- do _stopb <- (#peek DCB, StopBits) buf :: IO BYTE case _stopb of 0 -> return STypes.One 1 -> fail $ "unsupported one5stopbits" 2 -> return STypes.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 = STypes.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 = failIfFalse_ "setCommState" ( with dcb (c_SetCommState h)) --BOOL WINAPI SetCommState( -- __in HANDLE hFile, -- __in LPDCB lpDCB --); foreign import stdcall unsafe "winbase.h SetCommState" c_SetCommState :: HANDLE -> LPDCB -> IO BOOL -- | -- If an application sets ReadIntervalTimeout and ReadTotalTimeoutMultiplier to MAXDWORD and sets ReadTotalTimeoutConstant to a value greater than zero and less than MAXDWORD, one of the following occurs when the ReadFile function is called: -- -- * If there are any bytes in the input buffer, ReadFile returns immediately with the bytes in the buffer. -- -- * If there are no bytes in the input buffer, ReadFile waits until a byte arrives and then returns immediately. -- -- * If no bytes arrive within the time specified by ReadTotalTimeoutConstant, ReadFile times out. -- 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 -- | -- -- On success it returns nonzero. On failure, the return value is zero and the GetLastError should be called. -- setCommTimeouts :: HANDLE -> COMMTIMEOUTS -> IO () setCommTimeouts h ct = failIfFalse_ "setCommTimeouts" ( with ct (c_SetCommTimeouts h) ) -- setcommtimeouts -- winbase.h -> BOOL WINAPI SetCommTimeouts(HANDLE, LPCOMMTIMEOUTS); foreign import stdcall unsafe "winbase.h SetCommTimeouts" c_SetCommTimeouts :: HANDLE -> LPCOMMTIMEOUTS -> IO BOOL clrDTR :: DWORD clrDTR = #const CLRDTR setDTR :: DWORD setDTR = #const SETDTR -- -- foreign import stdcall unsafe "winbase.h EscapeCommFunction" c_EscapeCommFunction :: HANDLE -> DWORD -> IO BOOL escapeCommFunction :: HANDLE -> DWORD -> IO () escapeCommFunction h t = failIfFalse_ "excapeCommFunction" ( c_EscapeCommFunction h t )