serialport-0.1.0: System/Win32/Comm.hsc
{-# 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 <windows.h>
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 :: Int
} 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