diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,31 @@ +Copyright (c) 2009, 2010 Roel van Dijk + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * The name of Roel van Dijk and the names of contributors may NOT + be used to endorse or promote products derived from this + software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,51 @@ +#! /usr/bin/env runhaskell + +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE UnicodeSyntax #-} + +module Main (main) where + +------------------------------------------------------------------------------- +-- Imports +------------------------------------------------------------------------------- + +-- base +import Control.Monad ( (>>), return ) +import Data.Bool ( Bool ) +import System.Cmd ( system ) +import System.FilePath ( () ) +import System.IO ( IO ) + +-- cabal +import Distribution.Simple ( defaultMainWithHooks + , simpleUserHooks + , UserHooks(runTests, haddockHook) + , Args + ) + +import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) ) +import Distribution.Simple.Program ( userSpecifyArgs ) +import Distribution.Simple.Setup ( HaddockFlags ) +import Distribution.PackageDescription ( PackageDescription(..) ) + +------------------------------------------------------------------------------- + +main ∷ IO () +main = defaultMainWithHooks hooks + where + hooks = simpleUserHooks + { runTests = runTests' + , haddockHook = haddockHook' + } + +-- Run a 'test' binary that gets built when configured with '-ftest'. +runTests' ∷ Args → Bool → PackageDescription → LocalBuildInfo → IO () +runTests' _ _ _ _ = system testcmd >> return () + where testcmd = "." "dist" "build" "test" "test" + +-- Define __HADDOCK__ for CPP when running haddock. +haddockHook' ∷ PackageDescription → LocalBuildInfo → UserHooks → HaddockFlags → IO () +haddockHook' pkg lbi = + haddockHook simpleUserHooks pkg (lbi { withPrograms = p }) + where + p = userSpecifyArgs "haddock" ["--optghc=-D__HADDOCK__"] (withPrograms lbi) diff --git a/System/FTDI.hs b/System/FTDI.hs new file mode 100644 --- /dev/null +++ b/System/FTDI.hs @@ -0,0 +1,83 @@ +module System.FTDI + ( -- *Devices + Device + , ChipType(..) + , getChipType + , setChipType + , fromUSBDevice + , guessChipType + + -- *Interfaces + , Interface(..) + + -- *Device handles + , DeviceHandle + , resetUSB + , getTimeout + , setTimeout + , openDevice + , closeDevice + , withDeviceHandle + + -- *Interface handles + , InterfaceHandle + , getDeviceHandle + , getInterface + , openInterface + , closeInterface + , withInterfaceHandle + + -- *Data transfer + , ChunkedReaderT + , runChunkedReaderT + , readData + + -- **Low level bulk transfers + -- |These are low-level functions and as such they ignores things like: + -- + -- * Max packet size + -- + -- * Latency timer + -- + -- * Modem status bytes + -- + -- USB timeouts are not ignored, but they will prevent the request from + -- being completed. + , readBulk + , writeBulk + + -- *Control requests + , reset + , purgeReadBuffer + , purgeWriteBuffer + , getLatencyTimer + , setLatencyTimer + , BitMode(..) + , setBitMode + + -- **Line properties + , Parity(..) + , BitDataFormat(..) + , StopBits(..) + , setLineProperty + , BaudRate(..) + , nearestBaudRate + , setBaudRate + + -- **Modem status + , ModemStatus(..) + , pollModemStatus + + -- *Flow control + , FlowCtrl(..) + , setFlowControl + , setDTR + , setRTS + , setEventCharacter + , setErrorCharacter + + -- *Defaults + , defaultTimeout + ) where + +import System.FTDI.Internal diff --git a/System/FTDI/Internal.hs b/System/FTDI/Internal.hs new file mode 100644 --- /dev/null +++ b/System/FTDI/Internal.hs @@ -0,0 +1,921 @@ +{-# 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 ∷ 'InterfaceHandle' → IO () + example ifHnd = do + (packets1, rest1) ← runChunkedReaderT ('readData' ifHnd 400) 'BS.empty' + print $ 'BS.concat' packets1 + (packets2, rest2) ← runChunkedReaderT ('readData' ifHnd 200) rest1 + print $ 'BS.concat' packets2 +@ + +However, it is much easier to let 'ChunkedReaderT's monad instance handle the +plumbing: + +@ + example ∷ 'InterfaceHandle' → IO () + example ifHnd = + let reader = do packets1 ← 'readData' ifHnd 400 + liftIO $ print $ 'BS.concat' packets1 + packets2 ← '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) ← '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) diff --git a/System/FTDI/Properties.hs b/System/FTDI/Properties.hs new file mode 100644 --- /dev/null +++ b/System/FTDI/Properties.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving + , StandaloneDeriving + , TemplateHaskell + , UnicodeSyntax + #-} + +module System.FTDI.Properties where + + +------------------------------------------------------------------------------- +-- Imports +------------------------------------------------------------------------------- + +-- base +import Control.Applicative ( liftA2 ) +import Control.Arrow ( first ) +import Data.Bits ( (.&.) ) +import Data.Word ( Word8 ) + +-- base-unicode +import Data.Eq.Unicode ( (≡) ) +import Data.Function.Unicode ( (∘) ) +import Data.Ord.Unicode ( (≤) ) +import Prelude.Unicode ( (÷) ) + +-- derive +import Data.Derive.Arbitrary ( makeArbitrary ) +import Data.DeriveTH ( derive ) + +-- ftdi +import System.FTDI ( ModemStatus(..), ChipType(..) + , BaudRate(..), nearestBaudRate + ) +import System.FTDI.Internal ( marshalModemStatus + , unmarshalModemStatus + ) + +-- QuickCheck +import Test.QuickCheck ( Arbitrary, arbitrary, shrink, choose + , arbitraryBoundedIntegral + , shrinkIntegral, frequency + ) + +-- random +import System.Random ( Random ) + + +------------------------------------------------------------------------------- +-- Properties +------------------------------------------------------------------------------- + +prop_marshalModemStatus ∷ ModemStatus → Bool +prop_marshalModemStatus = + isIdentity ( uncurry unmarshalModemStatus + ∘ marshalModemStatus + ) + +prop_unmarshalModemStatus ∷ (Word8, Word8) → Bool +prop_unmarshalModemStatus = + -- The identity only holds when we ignore the 4 least significant bytes. + isIdentityWith (\x → (ignoreBits x ≡)) + ( marshalModemStatus + ∘ uncurry unmarshalModemStatus + ∘ ignoreBits + ) + where ignoreBits = first (.&. 0xf0) + +prop_baudRateError ∷ RealFrac α ⇒ α → (ChipType → BaudRate α → Bool) +prop_baudRateError maxError = \chip baudRate → + let b = nearestBaudRate chip baudRate + e = abs (b - baudRate) ÷ baudRate + in unBaudRate e ≤ maxError + + +------------------------------------------------------------------------------- +-- Misc +------------------------------------------------------------------------------- + +isIdentity ∷ Eq α ⇒ (α → α) → (α → Bool) +isIdentity = isIdentityWith (≡) + +isIdentityWith ∷ Eq α ⇒ (α → α → Bool) → (α → α) → (α → Bool) +isIdentityWith eq = liftA2 eq id + + +------------------------------------------------------------------------------- +-- Arbitrary instances +------------------------------------------------------------------------------- + +instance Arbitrary Word8 where + arbitrary = arbitraryBoundedIntegral + shrink = shrinkIntegral + +deriving instance Random α ⇒ Random (BaudRate α) + +instance (Random α, Num α, Arbitrary α) ⇒ Arbitrary (BaudRate α) where + arbitrary = frequency [ ( 1500000 - unBaudRate (minBound ∷ BaudRate Int) + , choose (minBound, 1500000) + ) + , (1, return 2000000) + , (1, return 3000000) + ] + shrink = map BaudRate ∘ shrink ∘ unBaudRate + +$( derive makeArbitrary ''ModemStatus ) +$( derive makeArbitrary ''ChipType ) diff --git a/System/FTDI/Utils.hs b/System/FTDI/Utils.hs new file mode 100644 --- /dev/null +++ b/System/FTDI/Utils.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE NoImplicitPrelude + , UnicodeSyntax + #-} + +module System.FTDI.Utils where + +------------------------------------------------------------------------------- +-- Imports +------------------------------------------------------------------------------- + +-- base +import Data.Bool ( Bool ) +import Data.Bits ( Bits, (.|.), (.&.), complement ) +import Data.Function ( ($) ) +import Data.List ( foldr ) +import Data.Ord ( Ord, min, max ) +import Prelude ( Enum, Bounded, minBound, maxBound + , Num, (+), Integral + , fromEnum, fromInteger, fromIntegral + , divMod + ) + +-- base-unicode-symbols +import Data.Bool.Unicode ( (∧) ) +import Data.Eq.Unicode ( (≢) ) +import Data.Ord.Unicode ( (≤) ) +import Data.Function.Unicode ( (∘) ) + + +------------------------------------------------------------------------------- +-- Utility functions +------------------------------------------------------------------------------- + +genFromEnum ∷ (Enum e, Num n) ⇒ e → n +genFromEnum = fromIntegral ∘ fromEnum + +orBits ∷ Bits α ⇒ [α] → α +orBits = foldr (.|.) 0 + +andBits ∷ Bits α ⇒ [α] → α +andBits = foldr (.&.) $ complement 0 + +clamp ∷ (Bounded α, Ord α) ⇒ α → α +clamp = atLeast minBound ∘ atMost maxBound + +atLeast ∷ Ord α ⇒ α → α → α +atLeast = max + +atMost ∷ Ord α ⇒ α → α → α +atMost = min + +divRndUp ∷ Integral α ⇒ α → α → α +divRndUp x y = let (d, m) = x `divMod` y + in d + if m ≢ 0 then 1 else 0 + +between ∷ Ord α ⇒ α → α → α → Bool +between lo hi x = lo ≤ x ∧ x ≤ hi diff --git a/System/FTDI/Utils/Properties.hs b/System/FTDI/Utils/Properties.hs new file mode 100644 --- /dev/null +++ b/System/FTDI/Utils/Properties.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE NoImplicitPrelude + , ScopedTypeVariables + , UnicodeSyntax + #-} + +module System.FTDI.Utils.Properties where + +-- base +import Control.Monad ( (>>) ) +import Data.Bool ( otherwise ) +import Data.Function ( ($) ) +import Data.Ord ( Ord ) +import Prelude ( Integral, RealFrac, Fractional, Double + , Bounded, minBound, maxBound + , fromInteger, toInteger, fromIntegral + , (+), abs, mod, ceiling, div + ) + +-- base-unicode +import Data.Bool.Unicode ( (∧) ) +import Data.Eq.Unicode ( (≡), (≢) ) +import Data.Ord.Unicode ( (≤), (≥) ) +import Prelude.Unicode ( (⋅), (÷) ) + +-- ftdi +import System.FTDI.Utils ( clamp, divRndUp ) + +-- QuickCheck +import Test.QuickCheck ( Property, (==>) ) + + +------------------------------------------------------------------------------- + +prop_divRndUp_min ∷ Integral α ⇒ α → α → Property +prop_divRndUp_min x y = y ≢ 0 ==> + let d = divRndUp x (abs y) + d' = toInteger d + y' = toInteger y + x' = toInteger x + in d' ⋅ abs y' ≥ x' + +prop_divRndUp_max ∷ Integral α ⇒ α → α → Property +prop_divRndUp_max x y = y ≢ 0 ==> + let d = divRndUp x y + in x `div` y ≤ d + +prop_divRndUp_ceilFrac ∷ Integral α ⇒ α → α → Property +prop_divRndUp_ceilFrac x y = y ≢ 0 ==> + let x' = fromIntegral x ∷ Double + y' = fromIntegral y ∷ Double + in divRndUp x y ≡ ceilFrac x' y' + +prop_divRndUp2 ∷ Integral α ⇒ α → α → Property +prop_divRndUp2 x y = y ≢ 0 ==> divRndUp x y ≡ divRndUp2 x y + +prop_clamp ∷ ∀ α. (Bounded α, Ord α) ⇒ α → Property +prop_clamp x = (minBound ∷ α) ≤ (maxBound ∷ α) + ==> minBound ≤ cx ∧ cx ≤ maxBound + where cx = clamp x + +------------------------------------------------------------------------------- + +ceilFrac ∷ (Fractional α, RealFrac α, Integral β) ⇒ α → α → β +ceilFrac x y = ceiling $ x ÷ y + +divRndUp2 ∷ Integral α ⇒ α → α → α +divRndUp2 x y = let r | mod x y ≡ 0 = 0 + | otherwise = 1 + in div x y + r diff --git a/ftdi.cabal b/ftdi.cabal new file mode 100644 --- /dev/null +++ b/ftdi.cabal @@ -0,0 +1,75 @@ +name: ftdi +version: 0.1 +cabal-version: >=1.6 +build-type: Custom +stability: experimental +author: Roel van Dijk +maintainer: Roel van Dijk +copyright: (c) 2009, 2010 Roel van Dijk +license: BSD3 +license-file: LICENSE +category: System +synopsis: A thin layer over USB to communicate with FTDI chips +description: + This library enables you to communicate with FTDI devices. It is + implemented as a lightweight wrapper around the usb library. + +source-repository head + type: darcs + location: http://code.haskell.org/~roelvandijk/code/ftdi + +------------------------------------------------------------------------------- + +flag test + description: Build the testing suite + default: False + +flag hpc + description: Enable program coverage on test executable + default: False + +flag nolib + description: Don't build the library + default: False + +------------------------------------------------------------------------------- + + +library + exposed-modules: System.FTDI + other-modules: System.FTDI.Internal + , System.FTDI.Utils + build-depends: base >= 4 && < 4.3 + , base-unicode-symbols >= 0.1.1 && < 0.2 + , bytestring >= 0.9.1 && < 0.10 + , safe >= 0.2 && < 0.3 + , transformers >= 0.1.4 && < 0.2 + , usb >= 0.3 && < 0.4 + ghc-options: -Wall + + if flag(nolib) + buildable: False + +------------------------------------------------------------------------------- + +executable test + main-is: test.hs + other-modules: System.FTDI.Internal + , System.FTDI.Properties + , System.FTDI.Utils + , System.FTDI.Utils.Properties + ghc-options: -Wall -fno-warn-orphans + + if flag(test) + build-depends: derive >= 2.3 && < 2.4 + , QuickCheck >= 2.1.0 && < 2.2 + , random >= 1.0.0 && < 1.1 + , tagged >= 0.0 && < 0.1 + , test-framework >= 0.2.4 && < 0.3 + , test-framework-quickcheck2 >= 0.2.4 && < 0.3 + buildable: True + else + buildable: False + + if flag(hpc) + ghc-options: -fhpc diff --git a/test.hs b/test.hs new file mode 100644 --- /dev/null +++ b/test.hs @@ -0,0 +1,124 @@ +{-# LANGUAGE NoImplicitPrelude + , ScopedTypeVariables + , UnicodeSyntax + #-} + +module Main where + +-- base +import Data.Bool ( Bool ) +import Data.Char ( String ) +import Data.Function ( ($) ) +import Data.Int ( Int ) +import Data.Ord ( Ord ) +import Data.Word ( Word8 ) +import Prelude ( Num, Integral, Integer, Bounded + , RealFrac, Float, Double + , fromRational + ) +import System.IO ( IO ) +import Text.Show ( Show ) + +-- test-framework +import Test.Framework ( Test, defaultMain, testGroup ) + +-- test-framework-quickcheck2 +import Test.Framework.Providers.QuickCheck2 ( testProperty ) + +-- QuickCheck +import Test.QuickCheck + +-- ftdi +import System.FTDI ( ChipType, BaudRate ) +import System.FTDI.Properties ( prop_marshalModemStatus + , prop_unmarshalModemStatus + , prop_baudRateError + ) +import System.FTDI.Utils.Properties ( prop_divRndUp_min + , prop_divRndUp_max + , prop_divRndUp_ceilFrac + , prop_divRndUp2 + , prop_clamp + ) + +-- random +import System.Random ( Random ) + +-- tagged +import Data.Tagged ( Tagged(Tagged, unTagged) ) + + +------------------------------------------------------------------------------- + +main ∷ IO () +main = defaultMain tests + +tests ∷ [Test] +tests = + [ testGroup "ftdi" + [ testGroup "modem status" + [ testProperty "marshal id" prop_marshalModemStatus + , testProperty "unmarshal id" prop_unmarshalModemStatus + ] + , testGroup "baud rate" + [ testGroup "error" + [ test_baudRate_error "Float" (0.05 ∷ Float) + , test_baudRate_error "Double" (0.05 ∷ Double) + ] + ] + ] + , testGroup "utilities" + [ testGroup "clamp" + [ unTagged (test_clamp "Int" ∷ Tagged Int Test) + , unTagged (test_clamp "Word8" ∷ Tagged Word8 Test) + , unTagged (test_clamp "BaudRate" ∷ Tagged (BaudRate Int) Test) + ] + , testGroup "divRndUp" + [ testGroup "min" + [ unTagged (test_divRndUp_min "Integer" ∷ Tagged Integer Test) + , unTagged (test_divRndUp_min "Int" ∷ Tagged Int Test) + , unTagged (test_divRndUp_min "Word8" ∷ Tagged Word8 Test) + ] + , testGroup "max" + [ unTagged (test_divRndUp_max "Integer" ∷ Tagged Integer Test) + , unTagged (test_divRndUp_max "Int" ∷ Tagged Int Test) + , unTagged (test_divRndUp_max "Word8" ∷ Tagged Word8 Test) + ] + , testGroup "ceilFrac" + [ unTagged (test_divRndUp_ceilFrac "Integer" ∷ Tagged Integer Test) + , unTagged (test_divRndUp_ceilFrac "Int" ∷ Tagged Int Test) + , unTagged (test_divRndUp_ceilFrac "Word8" ∷ Tagged Word8 Test) + ] + , testGroup "alternative2" + [ unTagged (test_divRndUp_alt2 "Integer" ∷ Tagged Integer Test) + , unTagged (test_divRndUp_alt2 "Int" ∷ Tagged Int Test) + , unTagged (test_divRndUp_alt2 "Word8" ∷ Tagged Word8 Test) + ] + ] + ] + ] + +test_baudRate_error ∷ ∀ α. (Arbitrary α, Random α, Num α, RealFrac α) ⇒ String → α → Test +test_baudRate_error n e = + testProperty n (prop_baudRateError e ∷ ChipType → BaudRate α → Bool) + +test_clamp ∷ ∀ α. (Arbitrary α, Bounded α, Ord α, Show α) ⇒ String → Tagged α Test +test_clamp n = + Tagged $ testProperty n (prop_clamp ∷ α → Property) + +test_divRndUp_min ∷ ∀ α. (Arbitrary α, Integral α) ⇒ String → Tagged α Test +test_divRndUp_min n = + Tagged $ testProperty n (prop_divRndUp_min ∷ α → α → Property) + +test_divRndUp_max ∷ ∀ α. (Arbitrary α, Integral α) ⇒ String → Tagged α Test +test_divRndUp_max n = + Tagged $ testProperty n (prop_divRndUp_max ∷ α → α → Property) + +test_divRndUp_ceilFrac ∷ ∀ α. (Arbitrary α, Integral α) ⇒ String → Tagged α Test +test_divRndUp_ceilFrac n = + Tagged $ testProperty n (prop_divRndUp_ceilFrac ∷ α → α → Property) + +test_divRndUp_alt2 ∷ ∀ α. (Arbitrary α, Integral α) ⇒ String → Tagged α Test +test_divRndUp_alt2 n = + Tagged $ testProperty n (prop_divRndUp2 ∷ α → α → Property) +