{-# LINE 1 "System/Hardware/Serialport/Posix.hsc" #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE DeriveDataTypeable       #-}
{-# LANGUAGE LambdaCase               #-}
{-# OPTIONS_HADDOCK hide #-}
module System.Hardware.Serialport.Posix where

import GHC.IO.Handle
import GHC.IO.Device (RawIO(..), IODevice(..), IODeviceType(Stream))
import GHC.IO.BufferedIO
import GHC.IO.Buffer
import GHC.IO.Encoding

import System.Posix.IO
import System.Posix.Types (Fd, ByteCount)
import System.Posix.Terminal

import Foreign (Ptr, castPtr, alloca, peek, with)
import Foreign.C

import Control.Monad (void)

import Data.Typeable
import Data.Bits
import qualified Data.ByteString.Char8 as B
import qualified Control.Exception     as Ex

import System.Hardware.Serialport.Types


data SerialPort = SerialPort
  { fd           :: Fd
  , portSettings :: SerialPortSettings
  } deriving (Show, Typeable)


instance RawIO SerialPort where
  read (SerialPort fd' _) ptr n = fromIntegral <$> fdReadBuf fd' ptr (fromIntegral n)
  readNonBlocking _ _ _ = error "readNonBlocking not implemented"
  write (SerialPort fd' _) ptr n = void $ fdWriteBuf fd' ptr (fromIntegral n)
  writeNonBlocking _ _ _ = error "writenonblocking not implemented"


instance IODevice SerialPort where
  ready _ _ _ = return True
  close = closeSerial
  isTerminal _ = return False
  isSeekable _ = return False
  seek _ _ _ = return ()
  tell _ = return 0
  getSize _ = return 0
  setSize _ _ = return ()
  setEcho _ _ = return ()
  getEcho _ = return False
  setRaw _ _ = return ()
  devType _ = return Stream


instance BufferedIO SerialPort where
  newBuffer _ = newByteBuffer 100
  fillReadBuffer = readBuf
  fillReadBuffer0 = readBufNonBlocking
  flushWriteBuffer = writeBuf
  flushWriteBuffer0 = writeBufNonBlocking


-- |Open and configure a serial port returning a standard Handle
hOpenSerial :: FilePath
           -> SerialPortSettings
           -> IO Handle
hOpenSerial dev settings = do
  ser <- openSerial dev settings
  h <- mkDuplexHandle ser dev Nothing noNewlineTranslation
  hSetBuffering h NoBuffering
  return h


-- |Open and configure a serial port
openSerial :: FilePath            -- ^ Serial port, such as @\/dev\/ttyS0@ or @\/dev\/ttyUSB0@
           -> SerialPortSettings
           -> IO SerialPort
openSerial dev settings = do
  fd' <- openFd dev ReadWrite Nothing defaultFileFlags { noctty = True, nonBlock = True }
  setFdOption fd' NonBlockingRead False
  let serial_port = SerialPort fd' defaultSerialSettings
  setSerialSettings serial_port settings


-- |Use specific encoding for an action and restore old encoding afterwards
withEncoding :: TextEncoding -> IO a -> IO a

{-# LINE 91 "System/Hardware/Serialport/Posix.hsc" #-}
withEncoding encoding fun = do
  cur_enc <- getForeignEncoding
  setForeignEncoding encoding
  result <- fun
  setForeignEncoding cur_enc
  return result

{-# LINE 100 "System/Hardware/Serialport/Posix.hsc" #-}


-- |Receive bytes, given the maximum number
recv :: SerialPort -> Int -> IO B.ByteString
recv (SerialPort fd' _) n = do
  result <- withEncoding char8 $ Ex.try $ fdRead fd' count :: IO (Either IOError (String, ByteCount))
  return $ case result of
     Right (str, _) -> B.pack str
     Left _         -> B.empty
  where
    count = fromIntegral n


-- |Send bytes
send
  :: SerialPort
  -> B.ByteString
  -> IO Int          -- ^ Number of bytes actually sent
send (SerialPort fd' _ ) msg =
  fromIntegral <$> withEncoding char8 (fdWrite fd' (B.unpack msg))


-- |Flush buffers
flush :: SerialPort -> IO ()
flush (SerialPort fd' _) =
  discardData fd' BothQueues


-- |Close the serial port
closeSerial :: SerialPort -> IO ()
closeSerial = closeFd . fd




foreign import ccall "ioctl" c_ioctl :: CInt -> CInt -> Ptr () -> IO CInt

cIoctl' :: Fd -> Int -> Ptr d -> IO ()
cIoctl' f req =
  throwErrnoIfMinus1_ "ioctl" .
     c_ioctl (fromIntegral f) (fromIntegral req) . castPtr


getTIOCM :: Fd -> IO Int
getTIOCM fd' =
  alloca $ \p -> cIoctl' fd' 21525 p >> peek p
{-# LINE 146 "System/Hardware/Serialport/Posix.hsc" #-}


setTIOCM :: Fd -> Int -> IO ()
setTIOCM fd' val =
  with val $ cIoctl' fd' 21528
{-# LINE 151 "System/Hardware/Serialport/Posix.hsc" #-}


-- |Set the Data Terminal Ready level
setDTR :: SerialPort -> Bool -> IO ()
setDTR (SerialPort fd' _) set = do
  current <- getTIOCM fd'
  setTIOCM fd' $ if set
                   then current .|. 2
{-# LINE 159 "System/Hardware/Serialport/Posix.hsc" #-}
                   else current .&. complement 2
{-# LINE 160 "System/Hardware/Serialport/Posix.hsc" #-}


-- |Set the Ready to send level
setRTS :: SerialPort -> Bool -> IO ()
setRTS (SerialPort fd' _) set = do
  current <- getTIOCM fd'
  setTIOCM fd' $ if set
                   then current .|. 4
{-# LINE 168 "System/Hardware/Serialport/Posix.hsc" #-}
                   else current .&. complement 4
{-# LINE 169 "System/Hardware/Serialport/Posix.hsc" #-}


-- |Configure the serial port
setSerialSettings :: SerialPort           -- ^ The currently opened serial port
                  -> SerialPortSettings   -- ^ The new settings
                  -> IO SerialPort        -- ^ New serial port
setSerialSettings (SerialPort fd' _) new_settings = do
  termOpts <- getTerminalAttributes fd'
  let termOpts' = configureSettings termOpts new_settings
  setTerminalAttributes fd' termOpts' Immediately
  return (SerialPort fd' new_settings)


-- |Get configuration from serial port
getSerialSettings :: SerialPort -> SerialPortSettings
getSerialSettings = portSettings


withParity :: TerminalAttributes -> Parity -> TerminalAttributes
withParity termOpts Even =
    termOpts `withMode` EnableParity
             `withoutMode` OddParity
withParity termOpts Odd =
    termOpts `withMode` EnableParity
             `withMode` OddParity
withParity termOpts NoParity =
    termOpts `withoutMode` EnableParity


withFlowControl :: TerminalAttributes -> FlowControl -> TerminalAttributes
withFlowControl termOpts NoFlowControl =
    termOpts `withoutMode` StartStopInput
             `withoutMode` StartStopOutput
withFlowControl termOpts Software =
    termOpts `withMode` StartStopInput
             `withMode` StartStopOutput


withStopBits :: TerminalAttributes -> StopBits -> TerminalAttributes
withStopBits termOpts One =
    termOpts `withoutMode` TwoStopBits
withStopBits termOpts Two =
    termOpts `withMode` TwoStopBits


configureSettings :: TerminalAttributes -> SerialPortSettings -> TerminalAttributes
configureSettings termOpts settings =
    termOpts `withInputSpeed` commSpeedToBaudRate (commSpeed settings)
             `withOutputSpeed` commSpeedToBaudRate (commSpeed settings)
             `withBits` fromIntegral (bitsPerWord settings)
             `withStopBits` stopb settings
             `withParity` parity settings
             `withFlowControl` flowControl settings
             `withoutMode` EnableEcho
             `withoutMode` EchoErase
             `withoutMode` EchoKill
             `withoutMode` ProcessInput
             `withoutMode` ProcessOutput
             `withoutMode` MapCRtoLF
             `withoutMode` EchoLF
             `withoutMode` HangupOnClose
             `withoutMode` KeyboardInterrupts
             `withoutMode` ExtendedFunctions
             `withMode` LocalMode
             `withMode` ReadEnable
             `withTime` timeout settings
             `withMinInput` 0


commSpeedToBaudRate :: CommSpeed -> BaudRate
commSpeedToBaudRate = \case
  CS110    -> B110
  CS300    -> B300
  CS600    -> B600
  CS1200   -> B1200
  CS2400   -> B2400
  CS4800   -> B4800
  CS9600   -> B9600
  CS19200  -> B19200
  CS38400  -> B38400
  CS57600  -> B57600
  CS115200 -> B115200