module System.Hardware.Parport
(
PP
, DD (..)
, claim
, release
, writePin
, writePins
, readPin
, readPins
, dataDirection
, test) where
import Foreign.C
import Foreign.Marshal
import Foreign.Ptr
import Foreign.Storable
import Control.Concurrent
import Control.Monad
import Data.Array.IArray
import Data.Bits
import Data.Maybe
foreign import ccall "rdwr" c_rdwr :: CInt
foreign import ccall unsafe "open" c_open :: CString -> CInt -> IO CInt
foreign import ccall unsafe "ppexcl" c_excl :: CInt -> IO ()
foreign import ccall unsafe "ppclaim" c_claim :: CInt -> IO ()
foreign import ccall unsafe "pprdata" c_pprdata :: CInt -> Ptr CChar -> IO ()
foreign import ccall unsafe "pprcontrol" c_pprcontrol :: CInt -> Ptr CChar -> IO ()
foreign import ccall unsafe "pprstatus" c_pprstatus :: CInt -> Ptr CChar -> IO ()
foreign import ccall unsafe "ppwcontrol" c_ppwcontrol :: CInt -> Ptr CChar -> IO ()
foreign import ccall unsafe "ppwdata" c_ppwdata :: CInt -> Ptr CChar -> IO ()
foreign import ccall unsafe "pprelease" c_release :: CInt -> IO ()
foreign import ccall unsafe "ppdatadir" c_datadir :: CInt -> CInt -> IO ()
data Reg = PPICTRL | PPIDATA | PPISTATUS deriving (Eq, Ord, Ix)
ppipins :: Array Int (Reg, Int, Bool)
ppipins = listArray (1, 17)
[ (PPICTRL, 0, False)
, (PPIDATA, 0, True)
, (PPIDATA, 1, True)
, (PPIDATA, 2, True)
, (PPIDATA, 3, True)
, (PPIDATA, 4, True)
, (PPIDATA, 5, True)
, (PPIDATA, 6, True)
, (PPIDATA, 7, True)
, (PPISTATUS, 6, True)
, (PPISTATUS, 7, False)
, (PPISTATUS, 5, True)
, (PPISTATUS, 4, True)
, (PPICTRL, 1, False)
, (PPISTATUS, 3, True)
, (PPICTRL, 2, True)
, (PPICTRL, 3, False)]
doFail :: String -> IO ()
doFail msg = do
e <- getErrno
if (e == eOK) then return () else throwErrno msg
data PP = PP (MVar PPDef)
data PPDef = PPDef {
fileD :: CInt
}
data DD = Input | Output
claim :: String -> IO PP
claim s = do
n <- newCString s
fd <- c_open n c_rdwr
doFail s
c_excl fd
c_claim fd
let ppdef = PPDef {
fileD = fd
}
doFail "while claiming parport"
r <- newMVar ppdef
let res = (PP r)
return res
dd2cint :: DD -> CInt
dd2cint Input = 0
dd2cint Output = 1
release :: PP -> IO ()
release (PP mvar) = do
ppdef <- takeMVar mvar
c_release (fileD ppdef)
doFail "while releasing parport"
ppr :: (CInt -> Ptr CChar -> IO ()) -> CInt -> IO CChar
ppr f fd = do
a <- malloc
f fd a
res <- peek a
free a
doFail "while writing to parport"
return res
ppw :: (CInt -> Ptr CChar -> IO ()) -> CInt -> CChar -> IO ()
ppw f fd v = do
a <- malloc
poke a v
f fd a
free a
doFail "while reading from parport"
return ()
pprdata, pprstatus, pprcontrol :: CInt -> IO CChar
pprstatus = ppr c_pprstatus
pprdata = ppr c_pprdata
pprcontrol = ppr c_pprcontrol
ppwdata, ppwcontrol :: CInt -> CChar -> IO ()
ppwdata = ppw c_ppwdata
ppwcontrol = ppw c_ppwcontrol
io :: PP -> Either [Int] [(Int, Bool)] -> IO (Maybe [Bool])
io (PP mvar) list = do
ppdef <- takeMVar mvar
let fd = fileD ppdef
dataR <- pprdata fd
controlR <- pprcontrol fd
statusR <- pprstatus fd
let
registers :: Array Reg CChar
registers = listArray (PPICTRL, PPISTATUS) [controlR, dataR, statusR]
res <- case list of
(Left getList) -> return $ Just $ map (\ nr -> let (reg, bitnr, inverse) = (ppipins!nr); b = testBit (registers!reg) bitnr in b /= inverse) getList
(Right modList) -> do
let ((newData, changedData), (newCtrl, changedCtrl)) = foldl (\ ((dR, dRC), (cR, cRC)) (nr, v) -> let (reg, bitnr, inverse) = ppipins!nr in case reg of
PPIDATA -> ((setBitTo dR bitnr (v /= inverse), True), (cR, cRC))
PPICTRL -> ((dR, dRC), (setBitTo cR bitnr (v /= inverse), True))
PPISTATUS -> error $ "will not write to status register (pin " ++ show nr ++ ")") ((dataR, False), (controlR, False)) modList
when changedData (ppwdata fd newData)
when changedCtrl (ppwcontrol fd newCtrl)
return Nothing
putMVar mvar ppdef
return res
setBitTo :: Bits b => b -> Int -> Bool -> b
setBitTo b i True = setBit b i
setBitTo b i False = clearBit b i
writePin :: PP -> Int -> Bool -> IO ()
writePin pp i b = writePins pp [(i, b)]
writePins :: PP -> [(Int, Bool)] -> IO ()
writePins pp l = io pp (Right l) >> return ()
readPin :: PP -> Int -> IO Bool
readPin pp i = readPins pp [i] >>= (return . head)
readPins :: PP -> [Int] -> IO [Bool]
readPins pp l = io pp (Left l) >>= (return . fromJust)
dataDirection :: PP -> DD -> IO ()
dataDirection (PP mvar) dd = do
ppdef <- takeMVar mvar
c_datadir (fileD ppdef) (dd2cint dd)
putMVar mvar ppdef
doFail "while setting data direction on parport's data register"
test :: IO ()
test = do
pp <- claim "/dev/parport0"
writePins pp (zip ([1..9] ++ [14] ++ [16, 17]) (repeat True))
watch pp
release pp
watch :: PP -> IO ()
watch pp = do
l <- readPins pp [1..17]
putStr (show l ++ "\r")
watch pp
return ()