ftdi (empty) → 0.1
raw patch · 9 files changed
+1517/−0 lines, 9 filesdep +QuickCheckdep +basedep +base-unicode-symbolsbuild-type:Customsetup-changed
Dependencies added: QuickCheck, base, base-unicode-symbols, bytestring, derive, random, safe, tagged, test-framework, test-framework-quickcheck2, transformers, usb
Files
- LICENSE +31/−0
- Setup.hs +51/−0
- System/FTDI.hs +83/−0
- System/FTDI/Internal.hs +921/−0
- System/FTDI/Properties.hs +106/−0
- System/FTDI/Utils.hs +57/−0
- System/FTDI/Utils/Properties.hs +69/−0
- ftdi.cabal +75/−0
- test.hs +124/−0
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -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)
+ System/FTDI.hs view
@@ -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
+ System/FTDI/Internal.hs view
@@ -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)
+ System/FTDI/Properties.hs view
@@ -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 )
+ System/FTDI/Utils.hs view
@@ -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
+ System/FTDI/Utils/Properties.hs view
@@ -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
+ ftdi.cabal view
@@ -0,0 +1,75 @@+name: ftdi+version: 0.1+cabal-version: >=1.6+build-type: Custom+stability: experimental+author: Roel van Dijk <vandijk.roel@gmail.com>+maintainer: Roel van Dijk <vandijk.roel@gmail.com>+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
+ test.hs view
@@ -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)+