{-# LANGUAGE PatternGuards, ForeignFunctionInterface #-}


-- | Interfacing the parallel port (currently only implemented for linux). This library is supposed to be thread-safe.
module System.Hardware.Parport
	(
	-- * Data types
	  PP
	, DD (..)

	-- * Claiming and releasing the parallel port
	, claim
	, release

	-- * Input/Output
	, writePin
	, writePins
	, readPin
	, readPins

	-- * Setup
	, dataDirection
	
	-- * Test/example function
	, 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

-- | The type of a claimed parallel port. Internally it holds an 'Control.Concurrent.MVar'
--   for threading.
data PP = PP (MVar PPDef)

data PPDef = PPDef {
	fileD :: CInt
}

-- | Description of the data-direction for the pins of the data register
data DD = Input | Output


-- | @claim \"\/dev\/parport0\"@ claims the parallel port exclusively and returns a handle.
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 a previously claimed parport.
release :: PP -> IO ()
release (PP mvar) = do
	ppdef <- takeMVar mvar -- We take it and do not give it back
	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 i b@ sets or clears pin i on pp, depending on the value of b.
writePin :: PP -> Int -> Bool -> IO ()
writePin pp i b = writePins pp [(i, b)]

-- | @writePins pp l@ is equal to @sequence (map (\(i, b) -> writePin pp i b) l)@
--   but it is faster.
writePins :: PP -> [(Int, Bool)] -> IO ()
writePins pp l = io pp (Right l) >> return ()

-- | @readPin pp i@ reads the value of pin i on pp and returns it in the IO monad.
readPin :: PP -> Int -> IO Bool
readPin pp i = readPins pp [i] >>= (return . head)

-- | @readPins pp l@ is equal to @sequence (map (readPin pp) l)@
--   but it is faster.
readPins :: PP -> [Int] -> IO [Bool]
readPins pp l = io pp (Left l) >>= (return . fromJust)


-- | Set the data direction of the data pins (pin 2-9).
--   On my system, i get an error \"bad address\". Please mail your experiences to me.
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"


-- | Run a simple test. View the source for an application example.
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 ()