{-# LANGUAGE CPP
           , DeriveDataTypeable
           , FlexibleContexts
           , GeneralizedNewtypeDeriving
           , NoImplicitPrelude
           , PatternGuards
           , ScopedTypeVariables
           , UnicodeSyntax
  #-}

module System.FTDI.Internal where

-------------------------------------------------------------------------------
-- Imports
-------------------------------------------------------------------------------

-- base
import Control.Applicative       ( Applicative, (<$>), Alternative )
import Control.Exception         ( Exception, bracket, throwIO )
import Control.Monad             ( Functor
                                 , Monad, (>>=), (>>), (=<<), return, fail
                                 , liftM
                                 , MonadPlus
                                 )
import Control.Monad.Fix         ( MonadFix )
import Data.Bool                 ( Bool, otherwise )
import Data.Bits                 ( Bits, (.|.)
                                 , setBit, shiftL, shiftR, testBit
                                 )
import Data.Data                 ( Data )
import Data.Eq                   ( Eq, (==) )
import Data.Function             ( ($), on )
import Data.Int                  ( Int )
import Data.List                 ( foldr, head, minimumBy, partition, zip )
import Data.Maybe                ( Maybe(Just, Nothing), maybe )
import Data.Ord                  ( Ord, (<), (>), compare )
import Data.Tuple                ( fst, snd )
import Data.Typeable             ( Typeable )
import Data.Word                 ( Word8, Word16 )
import Prelude                   ( Enum, succ
                                 , Bounded, minBound, maxBound
                                 , Num, (+), (-), Integral, (^)
                                 , Fractional, Real, RealFrac
                                 , Double, Integer
                                 , fromEnum, fromInteger, fromIntegral
                                 , realToFrac, floor, ceiling
                                 , div, error
                                 )
import System.IO                 ( IO )
import Text.Read                 ( Read )
import Text.Show                 ( Show )

-- base-unicode-symbols
import Data.Eq.Unicode           ( () )
import Data.Function.Unicode     ( () )
import Data.Monoid.Unicode       ( () )
import Prelude.Unicode           ( (), () )

-- bytestring
import qualified Data.ByteString as BS ( drop, length, null, splitAt, unpack )
#ifdef __HADDOCK__
import qualified Data.ByteString as BS ( empty )
#endif
import Data.ByteString           ( ByteString )

-- ftdi
import System.FTDI.Utils         ( divRndUp, clamp, genFromEnum, orBits )

-- safe
import Safe                      ( atMay, headMay )

-- transformers
import Control.Monad.Trans       ( MonadTrans, MonadIO, liftIO )
import Control.Monad.Trans.State ( StateT, get, put, runStateT )

-- usb
import qualified System.USB as USB


-------------------------------------------------------------------------------
-- Exceptions
-------------------------------------------------------------------------------

data FTDIException = InterfaceNotFound deriving (Show, Data, Typeable)

instance Exception FTDIException


-------------------------------------------------------------------------------
-- Request codes and values
-------------------------------------------------------------------------------

type RequestCode  = Word8
type RequestValue = Word16

reqReset            RequestCode
reqSetModemCtrl     RequestCode
reqSetFlowCtrl      RequestCode
reqSetBaudRate      RequestCode
reqSetData          RequestCode
reqPollModemStatus  RequestCode
reqSetEventChar     RequestCode
reqSetErrorChar     RequestCode
reqSetLatencyTimer  RequestCode
reqGetLatencyTimer  RequestCode
reqSetBitMode       RequestCode
reqReadPins         RequestCode
reqReadEEPROM       RequestCode
reqWriteEEPROM      RequestCode
reqEraseEEPROM      RequestCode

reqReset           = 0x00
reqSetModemCtrl    = 0x01
reqSetFlowCtrl     = 0x02
reqSetBaudRate     = 0x03
reqSetData         = 0x04
reqPollModemStatus = 0x05
reqSetEventChar    = 0x06
reqSetErrorChar    = 0x07
reqSetLatencyTimer = 0x09
reqGetLatencyTimer = 0x0A
reqSetBitMode      = 0x0B
reqReadPins        = 0x0C
reqReadEEPROM      = 0x90
reqWriteEEPROM     = 0x91
reqEraseEEPROM     = 0x92

valResetSIO          RequestValue
valPurgeReadBuffer   RequestValue
valPurgeWriteBuffer  RequestValue

valResetSIO         = 0
valPurgeReadBuffer  = 1
valPurgeWriteBuffer = 2

valSetDTRHigh  RequestValue
valSetDTRLow   RequestValue
valSetRTSHigh  RequestValue
valSetRTSLow   RequestValue

valSetDTRHigh = 0x0101
valSetDTRLow  = 0x0100
valSetRTSHigh = 0x0202
valSetRTSLow  = 0x0200


-------------------------------------------------------------------------------
-- Defaults
-------------------------------------------------------------------------------

-- |Default USB timeout. The timeout can be set per device handle with
-- the 'setTimeout' function.
defaultTimeout  Int
defaultTimeout = 5000


-------------------------------------------------------------------------------
-- Devices
-------------------------------------------------------------------------------

-- |A representation of an FTDI device. 
data Device = Device
    { devUSB       USB.Device
    , devUSBConf   USB.ConfigDesc
    , devChipType  ChipType
    }

-- |The type of FTDI chip in a 'Device'. The capabilities of a device
-- depend on its chip type.
data ChipType = ChipType_AM
              | ChipType_BM
              | ChipType_2232C
              | ChipType_R
              | ChipType_2232H
              | ChipType_4232H
                deriving (Enum, Eq, Ord, Show, Data, Typeable)

getChipType  Device  ChipType
getChipType = devChipType

setChipType  Device  ChipType  Device
setChipType dev ct = dev {devChipType = ct}

-- |Promote a USB device to an FTDI device. You are responsible for
-- supplying the correct USB device and specifying the correct chip
-- type. There is no failsafe way to automatically determine whether a
-- random USB device is an actual FTDI device.
fromUSBDevice  USB.Device -- ^ USB device
               ChipType
               Device     -- ^ FTDI device
fromUSBDevice dev chip =
  Device { devUSB      = dev
         , devUSBConf  = head  USB.deviceConfigs $ USB.deviceDesc dev
         , devChipType = chip
         }

-- |Tries to guess the type of the FTDI chip by looking at the USB
-- device release number of a device's descriptor. Each FTDI chip uses
-- a specific release number to indicate its type.
guessChipType  USB.DeviceDesc  Maybe ChipType
guessChipType desc = case USB.deviceReleaseNumber desc of
                       -- Workaround for bug in BM type chips
                       (0,2,0,0) | USB.deviceSerialNumberStrIx desc  0
                                              Just ChipType_BM
                                 | otherwise  Just ChipType_AM
                       (0,4,0,0)  Just ChipType_BM
                       (0,5,0,0)  Just ChipType_2232C
                       (0,6,0,0)  Just ChipType_R
                       (0,7,0,0)  Just ChipType_2232H
                       (0,8,0,0)  Just ChipType_4232H
                       _          Nothing

-------------------------------------------------------------------------------
-- Interfaces
-------------------------------------------------------------------------------

-- |A device interface. You can imagine an interface as a port or a
-- communication channel. Some devices support communication over
-- multiple interfaces at the same time.
data Interface = Interface_A
               | Interface_B
               | Interface_C
               | Interface_D
                 deriving (Enum, Eq, Ord, Show, Data, Typeable)

interfaceIndex  Interface  Word16
interfaceIndex = succ  genFromEnum

interfaceToUSB  Interface  USB.InterfaceNumber
interfaceToUSB = genFromEnum

interfaceEndPointIn  Interface  USB.EndpointAddress
interfaceEndPointIn i =
    USB.EndpointAddress { USB.endpointNumber    = 1 + 2  genFromEnum i
                        , USB.transferDirection = USB.In
                        }

interfaceEndPointOut  Interface  USB.EndpointAddress
interfaceEndPointOut i =
    USB.EndpointAddress { USB.endpointNumber    = 2 + 2  genFromEnum i
                        , USB.transferDirection = USB.Out
                        }

-------------------------------------------------------------------------------
-- Device Handles
-------------------------------------------------------------------------------

-- |You need a handle in order to communicate with a 'Device'.
data DeviceHandle = DeviceHandle
    { devHndUSB      USB.DeviceHandle
    , devHndDev      Device
    , devHndTimeout  Int
    }

-- |Perform a USB device reset.
resetUSB  DeviceHandle  IO ()
resetUSB = USB.resetDevice  devHndUSB

-- |Returns the USB timeout associated with a handle.
getTimeout  DeviceHandle  Int
getTimeout = devHndTimeout

-- |Modifies the USB timeout associated with a handle.
setTimeout  DeviceHandle  Int  DeviceHandle
setTimeout devHnd timeout = devHnd {devHndTimeout = timeout}

-- |Open a device handle to enable communication. Only use this if you
-- can't use 'withDeviceHandle' for some reason.
openDevice  Device  IO DeviceHandle
openDevice dev = do
  handle  USB.openDevice $ devUSB dev
  USB.setConfig handle $ USB.configValue $ devUSBConf dev
  return DeviceHandle { devHndUSB     = handle
                      , devHndDev     = dev
                      , devHndTimeout = defaultTimeout
                      }

-- |Release a device handle.
closeDevice  DeviceHandle  IO ()
closeDevice = USB.closeDevice  devHndUSB

-- |The recommended way to acquire a handle. Ensures that the handles
-- is released when the monadic computation is completed. Even, or
-- especially, when an exception is thrown.
withDeviceHandle  Device  (DeviceHandle  IO )  IO 
withDeviceHandle dev = bracket (openDevice dev) closeDevice

-------------------------------------------------------------------------------
-- Interface Handles
-------------------------------------------------------------------------------

data InterfaceHandle = InterfaceHandle
    { ifHndDevHnd     DeviceHandle
    , ifHndInterface  Interface
    , ifHndInEPDesc   USB.EndpointDesc
    , ifHndOutEPDesc  USB.EndpointDesc
    }

getDeviceHandle  InterfaceHandle  DeviceHandle
getDeviceHandle = ifHndDevHnd

getInterface  InterfaceHandle  Interface
getInterface = ifHndInterface

openInterface  DeviceHandle  Interface  IO InterfaceHandle
openInterface devHnd i =
    let conf    = devUSBConf $ devHndDev devHnd
        ifIx    = fromEnum i
        mIfDesc = headMay =<< USB.configInterfaces conf `atMay` ifIx
        mInOutEps = partition ((USB.In )  USB.transferDirection  USB.endpointAddress)
                     USB.interfaceEndpoints
                    <$> mIfDesc
        mInEp   = headMay  fst =<< mInOutEps
        mOutEp  = headMay  snd =<< mInOutEps
    in maybe (throwIO InterfaceNotFound)
             ( \ifHnd  do USB.claimInterface (devHndUSB devHnd) (interfaceToUSB i)
                           return ifHnd
             )
             $ do inEp   mInEp
                  outEp  mOutEp
                  return InterfaceHandle
                     { ifHndDevHnd    = devHnd
                     , ifHndInterface = i
                     , ifHndInEPDesc  = inEp
                     , ifHndOutEPDesc = outEp
                     }

closeInterface  InterfaceHandle  IO ()
closeInterface ifHnd =
    USB.releaseInterface (devHndUSB $ ifHndDevHnd ifHnd)
                         (interfaceToUSB $ ifHndInterface ifHnd)

withInterfaceHandle  DeviceHandle  Interface  (InterfaceHandle  IO )  IO 
withInterfaceHandle h i = bracket (openInterface h i) closeInterface

-------------------------------------------------------------------------------
-- Data transfer
-------------------------------------------------------------------------------

newtype ChunkedReaderT m  = ChunkedReaderT {unCR  StateT ByteString m }
    deriving ( Functor
             , Applicative
             , Alternative
             , Monad
             , MonadPlus
             , MonadTrans
             , MonadIO
             , MonadFix
             )

{-| Run the ChunkedReaderT given an initial state.

The initial state represents excess bytes carried over from a previous
run. When invoking runChunkedReaderT for the first time you can safely pass the
'BS.empty' bytestring as the initial state.

A contrived example showing how you can manually thread the excess bytes
through subsequent invocations of runChunkedReaderT:

@
  example &#x2237; 'InterfaceHandle' &#x2192; IO ()
  example ifHnd = do
    (packets1, rest1) &#x2190; runChunkedReaderT ('readData' ifHnd 400) 'BS.empty'
    print $ 'BS.concat' packets1
    (packets2, rest2) &#x2190; runChunkedReaderT ('readData' ifHnd 200) rest1
    print $ 'BS.concat' packets2
@

However, it is much easier to let 'ChunkedReaderT's monad instance handle the
plumbing:

@
  example &#x2237; 'InterfaceHandle' &#x2192; IO ()
  example ifHnd =
    let reader = do packets1 &#x2190; 'readData' ifHnd 400
                    liftIO $ print $ 'BS.concat' packets1
                    packets2 &#x2190; 'readData' ifHnd 200
                    liftIO $ print $ 'BS.concat' packets1
    in runChunkedReaderT reader 'BS.empty'
@

-}
runChunkedReaderT  ChunkedReaderT m   ByteString  m (, ByteString)
runChunkedReaderT = runStateT  unCR

{-| Reads data from the given FTDI interface by performing bulk reads.

This function produces an action in the ChunkedReaderT monad that, when
executed, will read exactly the requested number of bytes. Executing the
readData action will block until all data is read. The result value is a list
of chunks, represented as ByteStrings. This representation was choosen for
efficiency reasons.

Data is read in packets. The function may choose to request more than needed in
order to get the highest possible bandwidth. The excess of bytes is kept as the
state of the ChunkedReaderT monad. A subsequent invocation of readData will
first return bytes from the stored state before requesting more from the device
itself. A consequence of this behaviour is that even when you request 100 bytes
the function will actually request 512 bytes (depending on the packet size) and
/block/ until all 512 bytes are read! There is no workaround since requesting
less bytes than the packet size is an error.

USB timeouts will not interrupt readData. In case of a timeout readData will
simply resume reading data. A small USB timeout can degrade performance.

The FTDI latency timer can cause poor performance. If the FTDI chip can't fill
a packet before the latency timer fires it is forced to send an incomplete
packet. This will cause a stream of tiny packets instead of a few large
packets. Performance will suffer horribly, but the request will still be
completed.

If you need to make a lot of small requests then a small latency can actually
improve performance.

Modem status bytes are filtered from the result. Every packet send by the FTDI
chip contains 2 modem status bytes. They are not part of the data and do not
count for the number of bytes read. They will not appear in the result.

Example:

@
  -- Read 100 data bytes from ifHnd
  (packets, rest) &#x2190; 'runChunkedReaderT' ('readData' ifHnd 100) 'BS.empty'
@

-}
-- TODO: timeout
readData   m. MonadIO m  InterfaceHandle  Int  ChunkedReaderT m [ByteString]
readData ifHnd numBytes = ChunkedReaderT $
    do prevRest  get
       let readNumBytes = numBytes - BS.length prevRest
       if readNumBytes > 0
         then do chunks  readLoop readNumBytes
                 return $ if BS.null prevRest
                          then chunks
                          else prevRest : chunks
         else let (bs, newRest) = BS.splitAt numBytes prevRest
              in put newRest >> return [bs]
    where
      readLoop  Int  StateT ByteString m [ByteString]
      readLoop readNumBytes = do
        -- Amount of bytes we need to request in order to get atleast
        -- 'readNumBytes' bytes of data.
        let reqSize    = packetSize  reqPackets
            reqPackets = readNumBytes `divRndUp` packetDataSize
        -- Timeout is ignored; the number of bytes that was read contains
        -- enough information.
        (bytes, _)  liftIO $ readBulk ifHnd reqSize

        let receivedDataBytes   = receivedBytes - receivedHeaderBytes
            receivedBytes       = BS.length bytes
            receivedHeaderBytes = packetHeaderSize  receivedPackets
            receivedPackets     = receivedBytes `divRndUp` packetSize

        -- The reason for not actually getting the requested amount of bytes
        -- could be either a USB timeout or the FTDI latency timer firing.
        --
        -- In case of a USB timeout:
        --   ∃ (n : Nat). receivedBytes ≡ n ⋅ packetSize
        --
        -- In case of FTDI latency timer:
        --   receivedBytes < packetSize
        if receivedDataBytes < readNumBytes
          then let xs = splitPackets bytes
               in liftM (xs ) (readLoop $ readNumBytes - receivedDataBytes)
          else -- We might have received too much data, since we can only
               -- request multiples of 'packetSize' bytes. Split the byte
               -- string at such an index that the first part contains
               -- readNumBytes of data bytes. The rest is kept for future
               -- usage.
               let (bs, newRest) = BS.splitAt (splitIndex readNumBytes) bytes
               in put newRest >> return (splitPackets bs)

      splitIndex n = p  packetSize + packetHeaderSize
                     + (n - p  packetDataSize)
          where p = n `div` packetDataSize

      packetDataSize   = packetSize - packetHeaderSize
      packetHeaderSize = 2
      packetSize       = USB.maxPacketSize
                          USB.endpointMaxPacketSize
                         $ ifHndInEPDesc ifHnd

      -- |Split a stream of bytes into packets. The first 2 bytes of each
      -- packet are the modem status bytes and are dropped.
      splitPackets xs | BS.null xs = []
                      | otherwise  = case BS.splitAt packetSize xs of
                                       (a, b)  BS.drop 2 a : splitPackets b

-- |Perform a bulk read.
--
-- Returns the data that was read (in the form of a 'ByteString') and a flag
-- which indicates whether a timeout occured during the request.
readBulk  InterfaceHandle
          Int -- ^Number of bytes to read
          IO (ByteString, Bool)
readBulk ifHnd numBytes =
    USB.readBulk (devHndUSB $ ifHndDevHnd ifHnd)
                 (interfaceEndPointIn $ ifHndInterface ifHnd)
                 (devHndTimeout $ ifHndDevHnd ifHnd)
                 numBytes

-- |Perform a bulk write.
--
-- Returns the number of bytes that where written and a flag which indicates
-- whether a timeout occured during the request.
writeBulk  InterfaceHandle
           ByteString -- ^Data to be written
           IO (Int, Bool)
writeBulk ifHnd bs =
    USB.writeBulk (devHndUSB $ ifHndDevHnd ifHnd)
                  (interfaceEndPointOut $ ifHndInterface ifHnd)
                  (devHndTimeout $ ifHndDevHnd ifHnd)
                  bs

-------------------------------------------------------------------------------
-- Control Requests
-------------------------------------------------------------------------------

-- |The type of a USB control request.
type USBControl  = USB.DeviceHandle
                   USB.RequestType
                   USB.Recipient
                   RequestCode
                   RequestValue
                   Word16
                   USB.Timeout
                   

-- |Generic FTDI control request with explicit index
genControl  USBControl 
            Word16 -- ^Index
            InterfaceHandle
            RequestCode
            RequestValue
            
genControl usbCtrl index ifHnd request value =
    usbCtrl usbHnd
            USB.Vendor
            USB.ToDevice
            request
            value
            (index .|. (interfaceIndex $ ifHndInterface ifHnd))
            (devHndTimeout devHnd)
    where devHnd = ifHndDevHnd ifHnd
          usbHnd = devHndUSB devHnd

control  InterfaceHandle  RequestCode  Word16  IO ()
control = genControl USB.control 0

readControl  InterfaceHandle  RequestCode  Word16  USB.Size  IO (ByteString, Bool)
readControl = genControl USB.readControl 0

writeControl  InterfaceHandle  RequestCode  Word16  ByteString  IO (USB.Size, Bool)
writeControl = genControl USB.writeControl 0

-------------------------------------------------------------------------------

-- |Reset the FTDI device.
reset  InterfaceHandle  IO ()
reset ifHnd = control ifHnd reqReset valResetSIO

-- |Clear the on-chip read buffer.
purgeReadBuffer  InterfaceHandle  IO ()
purgeReadBuffer ifHnd = control ifHnd reqReset valPurgeReadBuffer

-- |Clear the on-chip write buffer.
purgeWriteBuffer  InterfaceHandle  IO ()
purgeWriteBuffer ifHnd = control ifHnd reqReset valPurgeWriteBuffer

-------------------------------------------------------------------------------

-- |Returns the current value of the FTDI latency timer.
getLatencyTimer  InterfaceHandle  IO Word8
getLatencyTimer ifHnd = do
    (bs, _)  readControl ifHnd reqGetLatencyTimer 0 1
    case BS.unpack bs of
      [b]  return b
      _    error "System.FTDI.getLatencyTimer: failed"

-- |Set the FTDI latency timer. The latency is the amount of
-- milliseconds after which the FTDI chip will send a packet
-- regardless of the number of bytes in the packet.
setLatencyTimer  InterfaceHandle  Word8  IO ()
setLatencyTimer ifHnd latency = control ifHnd reqSetLatencyTimer
                                        $ fromIntegral latency

-- |MPSSE bitbang modes
data BitMode = -- |Switch off bitbang mode, back to regular serial/FIFO.
               BitMode_Reset
               -- |Classical asynchronous bitbang mode, introduced with B-type
               -- chips.
             | BitMode_BitBang
               -- |Multi-Protocol Synchronous Serial Engine, available on 2232x
               -- chips.
             | BitMode_MPSSE
               -- |Synchronous Bit-Bang Mode, available on 2232x and R-type
               -- chips.
             | BitMode_SyncBitBang
               -- |MCU Host Bus Emulation Mode, available on 2232x
               -- chips. CPU-style fifo mode gets set via EEPROM.
             | BitMode_MCU
               -- |Fast Opto-Isolated Serial Interface Mode, available on 2232x
               -- chips.
             | BitMode_Opto
               -- |Bit-Bang on CBus pins of R-type chips, configure in EEPROM
               -- before use.
             | BitMode_CBus
               -- |Single Channel Synchronous FIFO Mode, available on 2232H
               -- chips.
             | BitMode_SyncFIFO
              deriving (Eq, Ord, Show, Data, Typeable)

marshalBitMode  BitMode  Word8
marshalBitMode bm = case bm of
                      BitMode_Reset        0x00
                      BitMode_BitBang      0x01
                      BitMode_MPSSE        0x02
                      BitMode_SyncBitBang  0x04
                      BitMode_MCU          0x08
                      BitMode_Opto         0x10
                      BitMode_CBus         0x20
                      BitMode_SyncFIFO     0x40

-- |The bitmode controls the method of communication.
setBitMode  InterfaceHandle  Word8  BitMode  IO ()
setBitMode ifHnd bitMask bitMode = control ifHnd reqSetBitMode value
    where bitMask' = fromIntegral bitMask
          bitMode' = fromIntegral $ marshalBitMode bitMode
          value    = bitMask' .|. shiftL bitMode' 8

-- |Sets the baud rate. Internally the baud rate is represented as a
-- fraction. The maximum baudrate is the numerator and a special
-- /divisor/ is used as the denominator. The maximum baud rate is
-- given by the 'BaudRate' instance for 'Bounded'. The divisor
-- consists of an integral part and a fractional part. Both parts are
-- limited in range. As a result not all baud rates can be accurately
-- represented. This function returns the nearest representable baud
-- rate relative to the requested baud rate. According to FTDI
-- documentation the maximum allowed error is 3%. The nearest
-- representable baud rate can be calculated with the
-- 'nearestBaudRate' function.
setBaudRate  RealFrac   InterfaceHandle  BaudRate   IO (BaudRate )
setBaudRate ifHnd baudRate =
  do genControl USB.control ix ifHnd reqSetBaudRate val
     return b
  where
    (val, ix) = encodeBaudRateDivisors chip d s
    (d, s, b) = calcBaudRateDivisors chip baudRate
    chip = devChipType $ devHndDev $ ifHndDevHnd ifHnd


data Parity = -- |The parity bit is set to one if the number of ones in a given
              -- set of bits is even (making the total number of ones, including
              -- the parity bit, odd).
              Parity_Odd
              -- |The parity bit is set to one if the number of ones in a given
              -- set of bits is odd (making the total number of ones, including
              -- the parity bit, even).
            | Parity_Even
            | Parity_Mark  -- ^The parity bit is always 1.
            | Parity_Space -- ^The parity bit is always 0.
              deriving (Enum, Eq, Ord, Show, Data, Typeable)

data BitDataFormat = Bits_7
                   | Bits_8

data StopBits = StopBit_1
              | StopBit_15
              | StopBit_2
                deriving (Enum)

-- |Set RS232 line characteristics
setLineProperty  InterfaceHandle
                 BitDataFormat -- ^Number of bits
                 StopBits      -- ^Number of stop bits
                 Maybe Parity  -- ^Optional parity mode
                 Bool          -- ^Break
                 IO ()
setLineProperty ifHnd bitDataFormat stopBits parity break' =
    control ifHnd
            reqSetData
            $ orBits [ case bitDataFormat of
                         Bits_7  7
                         Bits_8  8
                     , maybe 0 (\p  (1 + genFromEnum p) `shiftL` 8) parity
                     , genFromEnum stopBits `shiftL` 11
                     , genFromEnum break'   `shiftL` 14
                     ]

-------------------------------------------------------------------------------
-- Modem status
-------------------------------------------------------------------------------

-- |Modem status information. The modem status is send as a header for
-- each read access. In the absence of data the FTDI chip will
-- generate the status every 40 ms.
--
-- The modem status can be explicitely requested with the
-- 'pollModemStatus' function.
data ModemStatus = ModemStatus
    { -- |Clear to send (CTS)
      msClearToSend  Bool
      -- |Data set ready (DTS)
    , msDataSetReady  Bool
      -- |Ring indicator (RI)
    , msRingIndicator  Bool
      -- |Receive line signal detect (RLSD)
    , msReceiveLineSignalDetect  Bool
      -- | Data ready (DR)
    , msDataReady  Bool
      -- |Overrun error (OE)
    , msOverrunError  Bool
      -- |Parity error (PE)
    , msParityError  Bool
      -- |Framing error (FE)
    , msFramingError  Bool
      -- |Break interrupt (BI)
    , msBreakInterrupt  Bool
      -- |Transmitter holding register (THRE)
    , msTransmitterHoldingRegister  Bool
      -- |Transmitter empty (TEMT)
    , msTransmitterEmpty  Bool
      -- |Error in RCVR FIFO
    , msErrorInReceiverFIFO  Bool
    } deriving (Eq, Ord, Show, Data, Typeable)

marshalModemStatus  ModemStatus  (Word8, Word8)
marshalModemStatus ms = (a, b)
    where
      a = mkByte $ zip [4..]
                       [ msClearToSend
                       , msDataSetReady
                       , msRingIndicator
                       , msReceiveLineSignalDetect
                       ]
      b = mkByte $ zip [0..]
                       [ msDataReady
                       , msOverrunError
                       , msParityError
                       , msFramingError
                       , msBreakInterrupt
                       , msTransmitterHoldingRegister
                       , msTransmitterEmpty
                       , msErrorInReceiverFIFO
                       ]

      mkByte  [(Int, ModemStatus  Bool)]  Word8
      mkByte ts = foldr (\(n, f) x  if f ms then setBit x n else x)
                        0
                        ts

unmarshalModemStatus  Word8  Word8  ModemStatus
unmarshalModemStatus a b =
    ModemStatus { msClearToSend                = testBit a 4
                , msDataSetReady               = testBit a 5
                , msRingIndicator              = testBit a 6
                , msReceiveLineSignalDetect    = testBit a 7
                , msDataReady                  = testBit b 0
                , msOverrunError               = testBit b 1
                , msParityError                = testBit b 2
                , msFramingError               = testBit b 3
                , msBreakInterrupt             = testBit b 4
                , msTransmitterHoldingRegister = testBit b 5
                , msTransmitterEmpty           = testBit b 6
                , msErrorInReceiverFIFO        = testBit b 7
                }

-- |Manually request the modem status.
pollModemStatus  InterfaceHandle  IO ModemStatus
pollModemStatus ifHnd = do
    (bs, _)  readControl ifHnd reqPollModemStatus 0 2
    case BS.unpack bs of
      [x,y]  return $ unmarshalModemStatus x y
      _      error "System.FTDI.pollModemStatus: failed"


-------------------------------------------------------------------------------
-- Flow control
-------------------------------------------------------------------------------

data FlowCtrl = RTS_CTS -- ^Request-To-Send \/ Clear-To-Send
              | DTR_DSR -- ^Data-Terminal-Ready \/ Data-Set-Ready
              | XOnXOff -- ^Transmitter on \/ Transmitter off

marshalFlowControl  FlowCtrl  Word16
marshalFlowControl f = case f of
                         RTS_CTS  0x0100
                         DTR_DSR  0x0200
                         XOnXOff  0x0400

-- |Set the flow control for the FTDI chip. Use 'Nothing' to disable flow
-- control.
setFlowControl  InterfaceHandle  Maybe FlowCtrl  IO ()
setFlowControl ifHnd mFC = genControl USB.control
                                      (maybe 0 marshalFlowControl mFC)
                                      ifHnd
                                      reqSetFlowCtrl
                                      0

-- |Set DTR line.
setDTR  InterfaceHandle  Bool  IO ()
setDTR ifHnd b = control ifHnd reqSetModemCtrl
               $ if b then valSetDTRHigh else valSetDTRLow

-- |Set RTS line.
setRTS  InterfaceHandle  Bool  IO ()
setRTS ifHnd b = control ifHnd reqSetModemCtrl
               $ if b then valSetRTSHigh else valSetRTSLow

genSetCharacter  RequestCode  InterfaceHandle  Maybe Word8  IO ()
genSetCharacter req ifHnd mEC =
    control ifHnd req $ maybe 0 (\c  setBit (fromIntegral c) 8) mEC

-- |Set the special event character. Use 'Nothing' to disable the event
-- character.
setEventCharacter  InterfaceHandle  Maybe Word8  IO ()
setEventCharacter = genSetCharacter reqSetEventChar

-- |Set the error character.  Use 'Nothing' to disable the error character.
setErrorCharacter  InterfaceHandle  Maybe Word8  IO ()
setErrorCharacter = genSetCharacter reqSetErrorChar


-------------------------------------------------------------------------------
-- Baud rate
-------------------------------------------------------------------------------

newtype BRDiv  = BRDiv {unBRDiv  }
    deriving ( Eq, Ord, Show, Read, Enum, Num, Integral
             , Real, Fractional, RealFrac
             )

instance Num   Bounded (BRDiv ) where
    minBound = 0
    maxBound = 2 ^ (14  Int) - 1

newtype BRSubDiv  = BRSubDiv {unBRSubDiv  }
    deriving ( Eq, Ord, Show, Read, Enum, Num, Integral
             , Real, Fractional, RealFrac
             )

instance Num   Bounded (BRSubDiv ) where
    minBound = 0
    maxBound = 7

-- |Representation of a baud rate. The most interesting part is the
-- instance for 'Bounded'.
newtype BaudRate  = BaudRate {unBaudRate  }
    deriving ( Eq, Ord, Show, Read, Enum, Num, Integral
             , Real, Fractional, RealFrac
             )

instance Num   Bounded (BaudRate ) where
    -- Minimum baud rate is the maximum baudrate divided by the
    -- largest possible divider.
    minBound = fromIntegral
               $ (ceiling  BaudRate Double  BaudRate Integer)
               $ calcBaudRate maxBound maxBound

    maxBound = BaudRate 3000000

-- http://www.ftdichip.com/Documents/AppNotes/AN232B-05_BaudRates.pdf
encodeBaudRateDivisors  ChipType  BRDiv Int  BRSubDiv Int  (Word16, Word16)
encodeBaudRateDivisors chip d s = (v, i)
  where
    v = fromIntegral d .|. shiftL s' 14
    i | ChipType_2232C  chip = shiftL (shiftR s' 2) 8
      | otherwise = shiftR s' 2
    s' = fromIntegral $ encodeSubDiv s  Word16

    encodeSubDiv  BRSubDiv Int  Int
    encodeSubDiv n =
        case n of
          0  0 -- 000 ==> 0/8 = 0
          4  1 -- 001 ==> 4/8 = 0.5
          2  2 -- 010 ==> 2/8 = 0.25
          1  3 -- 011 ==> 1/8 = 0.125
          3  4 -- 100 ==> 3/8 = 0.375
          5  5 -- 101 ==> 5/8 = 0.625
          6  6 -- 110 ==> 6/8 = 0.75
          7  7 -- 111 ==> 7/8 = 0.875
          _  error "Illegal subdivisor"

-- |Calculates the nearest representable baud rate.
nearestBaudRate  RealFrac   ChipType  BaudRate   BaudRate 
nearestBaudRate chip baudRate = b
  where (_, _, b) = calcBaudRateDivisors chip baudRate


-- |Finds the divisors that most closely represent the requested baud rate.
calcBaudRateDivisors   . RealFrac 
                      ChipType
                      BaudRate 
                      (BRDiv Int, BRSubDiv Int, BaudRate )
calcBaudRateDivisors _    3000000  = (0, 0, 0)
calcBaudRateDivisors _    2000000  = (1, 0, 0)
calcBaudRateDivisors chip baudRate =
    minimumBy (compare `on` (\(_,_,x)  x))
              [ (d, s, b')
              | s  chipSubDivisors chip
              , let s' = fromIntegral s  8
                    d  = divisor baudRate s'
                    -- Baud rate calculated from found divisors.
                    b' = calcBaudRate d s'
              ]
    where
      -- |Calculates the divisor from a baud rate and a subdivisor.
      divisor  Integral β  BaudRate   BRSubDiv   BRDiv β
      divisor br s = clamp $ floor $ (maxBound - br  s')  br
          where s' = BaudRate $ unBRSubDiv s

      chipSubDivisors  ChipType  [BRSubDiv Int]
      chipSubDivisors ChipType_AM = [0, 1, 2, 4]
      chipSubDivisors _           = [0..7]

-- |Calculates the baud rate from a divisor and a subdivisor.
calcBaudRate  Fractional   BRDiv Int  BRSubDiv   BaudRate 
calcBaudRate 0 0 = maxBound
calcBaudRate 1 0 = 2000000
calcBaudRate d s = maxBound  BaudRate (realToFrac d + unBRSubDiv s)