diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,7 @@ +# Revision history for ftdi + +## 0.3.0.0 -- 2021-04-10 + +* Major project update +* MPSSE support +* Additional documentation diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,15 @@ +# ftdi +[![Haskell CI](https://github.com/standardsemiconductor/ftdi/workflows/Haskell%20CI/badge.svg?branch=master)](https://github.com/standardsemiconductor/ftdi/actions/workflows/haskell.yml) +[![Hackage][hackage-badge]][hackage] +[![Hackage Dependencies][hackage-deps-badge]][hackage-deps] + +This library enables you to communicate with FTDI devices. It is implemented as a lightweight wrapper around the [usb](https://hackage.haskell.org/package/usb) library. + +## References +* [FTDI Website](https://ftdichip.com/) +* [Application Note AN_108](https://www.ftdichip.com/Support/Documents/AppNotes/AN_108_Command_Processor_for_MPSSE_and_MCU_Host_Bus_Emulation_Modes.pdf): Command Processor for MPSSE and MCU Host Bus Emulation Modes + +[hackage]: +[hackage-badge]: +[hackage-deps-badge]: +[hackage-deps]: diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,51 +1,2 @@ -#! /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) +import Distribution.Simple +main = defaultMain diff --git a/System/FTDI.hs b/System/FTDI.hs --- a/System/FTDI.hs +++ b/System/FTDI.hs @@ -18,7 +18,6 @@ , openDevice , closeDevice , withDeviceHandle - -- *Interface handles , InterfaceHandle , getDeviceHandle @@ -26,7 +25,8 @@ , openInterface , closeInterface , withInterfaceHandle - + -- *Kernel drivers + , withDetachedKernelDriver -- *Data transfer , ChunkedReaderT , runChunkedReaderT diff --git a/System/FTDI/Internal.hs b/System/FTDI/Internal.hs --- a/System/FTDI/Internal.hs +++ b/System/FTDI/Internal.hs @@ -1,5 +1,6 @@ {-# LANGUAGE CPP , DeriveDataTypeable + , DeriveGeneric , FlexibleContexts , GeneralizedNewtypeDeriving , NoImplicitPrelude @@ -18,36 +19,34 @@ import Control.Applicative ( Applicative, (<$>), Alternative ) import Control.Exception ( Exception, bracket, throwIO ) import Control.Monad ( Functor - , Monad, (>>=), (>>), (=<<), return, fail - , liftM + , Monad, (>>=), (>>), (=<<), return , MonadPlus ) import Control.Monad.Fix ( MonadFix ) -import Data.Bool ( Bool, otherwise ) -#ifdef __HADDOCK__ -import Data.Bool ( Bool(False, True) ) -#endif -import Data.Bits ( Bits, (.|.) +import Data.Bool +import Data.Bits ( (.|.) , setBit, shiftL, shiftR, testBit ) import Data.Data ( Data ) -import Data.Eq ( Eq, (==) ) +import Data.Eq ( Eq ) import Data.Function ( ($), on ) import Data.Int ( Int ) -import Data.List ( foldr, head, minimumBy, partition, zip ) +import Data.List ( foldr, minimumBy, 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 GHC.Generics ( Generic ) import Prelude ( Enum, succ , Bounded, minBound, maxBound , Num, (+), (-), Integral, (^) , Fractional, Real, RealFrac , Double, Integer - , fromEnum, fromInteger, fromIntegral + , fromEnum, fromIntegral , realToFrac, floor, ceiling , div, error + , fmap, (.) ) import System.IO ( IO ) import Text.Read ( Read ) @@ -68,8 +67,8 @@ -- from ftdi: import System.FTDI.Utils ( divRndUp, clamp, genFromEnum, orBits ) --- from safe: -import Safe ( atMay, headMay ) +-- from vector: +import qualified Data.Vector as V -- from transformers: import Control.Monad.Trans.State ( StateT, get, put, runStateT ) @@ -176,7 +175,7 @@ | ChipType_R | ChipType_2232H | ChipType_4232H - deriving (Enum, Eq, Ord, Show, Data, Typeable) + deriving (Enum, Eq, Ord, Show, Data, Typeable, Generic) getChipType ∷ Device → ChipType getChipType = devChipType @@ -190,12 +189,13 @@ -- 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 - } + → IO Device -- ^ FTDI device +fromUSBDevice dev chip = do + config <- USB.getConfigDesc dev 0 + return Device { devUSB = dev + , devUSBConf = config + , 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 @@ -203,7 +203,7 @@ 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 + (0,2,0,0) | USB.deviceSerialNumberStrIx desc ≡ Just 0 → Just ChipType_BM | otherwise → Just ChipType_AM (0,4,0,0) → Just ChipType_BM @@ -272,7 +272,7 @@ openDevice ∷ Device → IO DeviceHandle openDevice dev = do handle ← USB.openDevice $ devUSB dev - USB.setConfig handle $ USB.configValue $ devUSBConf dev +-- USB.setConfig handle $ Just $ USB.configValue $ devUSBConf dev return DeviceHandle { devHndUSB = handle , devHndDev = dev , devHndTimeout = defaultTimeout @@ -280,7 +280,7 @@ -- |Release a device handle. closeDevice ∷ DeviceHandle → IO () -closeDevice = USB.closeDevice ∘ devHndUSB +closeDevice = USB.closeDevice . devHndUSB -- |The recommended way to acquire a handle. Ensures that the handle -- is released when the monadic computation is completed. Even, or @@ -309,12 +309,13 @@ 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) + mIfDesc = (USB.configInterfaces conf V.!? ifIx) >>= headMay + mInOutEps = V.partition ((USB.In ≡) ∘ USB.transferDirection ∘ USB.endpointAddress) ∘ USB.interfaceEndpoints <$> mIfDesc mInEp = headMay ∘ fst =<< mInOutEps mOutEp = headMay ∘ snd =<< mInOutEps + headMay = (V.!? 0) in maybe (throwIO InterfaceNotFound) ( \ifHnd → do USB.claimInterface (devHndUSB devHnd) (interfaceToUSB i) return ifHnd @@ -329,14 +330,20 @@ } closeInterface ∷ InterfaceHandle → IO () -closeInterface ifHnd = - USB.releaseInterface (devHndUSB $ ifHndDevHnd ifHnd) - (interfaceToUSB $ ifHndInterface ifHnd) +closeInterface ifHnd = USB.releaseInterface (devHndUSB $ ifHndDevHnd ifHnd) + (interfaceToUSB $ ifHndInterface ifHnd) withInterfaceHandle ∷ DeviceHandle → Interface → (InterfaceHandle → IO α) → IO α withInterfaceHandle h i = bracket (openInterface h i) closeInterface ------------------------------------------------------------------------------- +-- Kernel drivers +------------------------------------------------------------------------------- +withDetachedKernelDriver :: DeviceHandle -> Interface -> IO a -> IO a +withDetachedKernelDriver devHndl i = + USB.withDetachedKernelDriver (devHndUSB devHndl) (interfaceToUSB i) + +------------------------------------------------------------------------------- -- Data transfer ------------------------------------------------------------------------------- @@ -423,7 +430,7 @@ 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 +Modem status bytes are filtered from the result. Every packet sent 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. @@ -479,8 +486,8 @@ in lift checkStop >>= \stop → if stop then put BS.empty >> return xs - else liftM (xs ⊕) - (readLoop $ readNumBytes - receivedDataBytes) + else fmap (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 @@ -510,12 +517,11 @@ -- which indicates whether a timeout occured during the request. readBulk ∷ InterfaceHandle → Int -- ^Number of bytes to read - → IO (ByteString, Bool) -readBulk ifHnd numBytes = + → IO (ByteString, USB.Status) +readBulk ifHnd = USB.readBulk (devHndUSB $ ifHndDevHnd ifHnd) (interfaceEndPointIn $ ifHndInterface ifHnd) (devHndTimeout $ ifHndDevHnd ifHnd) - numBytes -- |Perform a bulk write. -- @@ -523,12 +529,12 @@ -- whether a timeout occured during the request. writeBulk ∷ InterfaceHandle → ByteString -- ^Data to be written - → IO (Int, Bool) + → IO (Int, USB.Status) writeBulk ifHnd bs = USB.writeBulk (devHndUSB $ ifHndDevHnd ifHnd) (interfaceEndPointOut $ ifHndInterface ifHnd) - (devHndTimeout $ ifHndDevHnd ifHnd) bs + (devHndTimeout $ ifHndDevHnd ifHnd) ------------------------------------------------------------------------------- -- Control Requests @@ -536,40 +542,37 @@ -- |The type of a USB control request. type USBControl α = USB.DeviceHandle - → USB.RequestType - → USB.Recipient - → RequestCode - → RequestValue - → Word16 + → USB.ControlSetup → USB.Timeout → α -- |Generic FTDI control request with explicit index genControl ∷ USBControl α - → Word16 -- ^Index + → USB.Index -- ^Index → InterfaceHandle → RequestCode → RequestValue → α genControl usbCtrl index ifHnd request value = - usbCtrl usbHnd - USB.Vendor - USB.ToDevice - request - value - (index .|. (interfaceIndex $ ifHndInterface ifHnd)) - (devHndTimeout devHnd) + usbCtrl usbHnd setup (devHndTimeout devHnd) where devHnd = ifHndDevHnd ifHnd usbHnd = devHndUSB devHnd + index' = index .|. interfaceIndex (ifHndInterface ifHnd) + setup = USB.ControlSetup { USB.controlSetupRequestType = USB.Vendor + , USB.controlSetupRecipient = USB.ToDevice + , USB.controlSetupRequest = request + , USB.controlSetupValue = value + , USB.controlSetupIndex = index' + } -control ∷ InterfaceHandle → RequestCode → Word16 → IO () +control ∷ InterfaceHandle → RequestCode → USB.Value → IO () control = genControl USB.control 0 -readControl ∷ InterfaceHandle → RequestCode → Word16 → USB.Size → IO (ByteString, Bool) +readControl ∷ InterfaceHandle → RequestCode → USB.Value → USB.Size → IO (ByteString, USB.Status) readControl = genControl USB.readControl 0 -writeControl ∷ InterfaceHandle → RequestCode → Word16 → ByteString → IO (USB.Size, Bool) -writeControl = genControl USB.writeControl 0 +writeControl ∷ InterfaceHandle → RequestCode → USB.Value → ByteString → IO (USB.Size, USB.Status) +writeControl = genControl (\hdl setup timeout bs -> USB.writeControl hdl setup bs timeout) 0 ------------------------------------------------------------------------------- @@ -652,7 +655,7 @@ -- 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 + -- 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 @@ -740,7 +743,7 @@ , msTransmitterEmpty ∷ Bool -- |Error in RCVR FIFO , msErrorInReceiverFIFO ∷ Bool - } deriving (Eq, Ord, Show, Data, Typeable) + } deriving (Eq, Ord, Show, Data, Typeable, Generic) marshalModemStatus ∷ ModemStatus → (Word8, Word8) marshalModemStatus ms = (a, b) @@ -763,9 +766,7 @@ ] mkByte ∷ [(Int, ModemStatus → Bool)] → Word8 - mkByte ts = foldr (\(n, f) x → if f ms then setBit x n else x) - 0 - ts + mkByte = foldr (\(n, f) x → if f ms then setBit x n else x) 0 unmarshalModemStatus ∷ Word8 → Word8 → ModemStatus unmarshalModemStatus a b = @@ -932,7 +933,7 @@ chipSubDivisors _ = [0..7] -- |Calculates the baud rate from a divisor and a subdivisor. -calcBaudRate ∷ Fractional α ⇒ BRDiv Int → BRSubDiv α → BaudRate α +calcBaudRate ∷ (Eq α, 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/MPSSE.hs b/System/FTDI/MPSSE.hs new file mode 100644 --- /dev/null +++ b/System/FTDI/MPSSE.hs @@ -0,0 +1,343 @@ +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE BangPatterns #-} +module System.FTDI.MPSSE + ( Command + , run + , Failure(..) + + -- * Clock divisor + , setClockDivisor + + -- ** FT232H divide-by-5 + , enableClkDivBy5 + , disableClkDivBy5 + + , enable3PhaseClocking + , disable3PhaseClocking + + -- * Loopback + , enableLoopback + , disableLoopback + + -- * Data transfer + , BitOrder(..) + , ClockEdge(..) + , flush + + -- ** Pausing + , waitOnHigh + , waitOnLow + -- ** Byte-wise + , readBytes + , writeBytes + , readWriteBytes + + -- * GPIO + , Gpios(..) + , allInputs + , Direction(..) + , GpioBank(..) + , setGpioDirValue + , getGpioValue + ) where + +import Data.Bits +import Data.Word +import Numeric (showHex) + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Builder as BSB + +import Control.Concurrent.Async + +import qualified System.FTDI as FTDI +import System.FTDI (InterfaceHandle) +import System.IO + +debug :: Bool +debug = False + +debugLog :: String -> IO () +debugLog + | debug = hPutStrLn stderr + | otherwise = const $ return () + +-- Useful for debugging +showBS :: BS.ByteString -> String +showBS = foldr (\n rest -> showHex n . showChar ' ' $ rest) "" . BS.unpack + +data Command a = Command { command :: BSB.Builder + , expectedBytes :: !Int + , parseBytes :: BS.ByteString -> a + } + +instance Functor Command where + fmap f (Command a b c) = Command a b (f . c) + {-# INLINE fmap #-} + +instance Applicative Command where + pure x = Command mempty 0 (const x) + {-# INLINE pure #-} + Command a b c <*> Command a' b' c' = + Command (a <> a') (b + b') parse + where + parse bs = + let (bs1, bs2) = BS.splitAt b bs + in c bs1 (c' bs2) + {-# INLINE (<*>) #-} + +opCode :: Word8 -> Command () +opCode = byte +{-# INLINE opCode #-} + +byte :: Word8 -> Command () +byte o = () <$ transfer (BSB.word8 o) 0 +{-# INLINE byte #-} + +word16 :: Word16 -> Command () +word16 o = () <$ transfer (BSB.word16LE o) 0 +{-# INLINE word16 #-} + +transfer :: BSB.Builder -> Int -> Command BS.ByteString +transfer b n = Command { command = b + , expectedBytes = n + , parseBytes = id } +{-# INLINE transfer #-} + +writeByteString :: BS.ByteString -> Command () +writeByteString bs = () <$ transfer (BSB.byteString bs) 0 +{-# INLINE writeByteString #-} + +readN :: Int -> Command BS.ByteString +readN = transfer mempty +{-# INLINE readN #-} + +------------------------------------------------------------------------------- +-- Interpreter +------------------------------------------------------------------------------- + +data Failure = WriteTimedOut BS.ByteString Int + -- ^ content to be written and number of bytes actually written. + | ReadTimedOut BS.ByteString Int BS.ByteString + -- ^ data written, expected returned bytes, and data actually read. + | ReadTooLong Int BS.ByteString + -- ^ bytes expected and content actually read. + | BadStatus BS.ByteString + +instance Show Failure where + show (WriteTimedOut write written) = + unlines [ "Write timed out:" + , " Wrote " <> show written <> " of " <> show (BS.length write) <> ": " <> showBS write + ] + show (ReadTimedOut written expected readBS) = + unlines [ "Read timed out:" + , " Wrote " <> show (BS.length written) <> ": " <> showBS written + , " Expected to read " <> show expected + , " Actually read " <> show (BS.length readBS) <> ": " <> showBS readBS + ] + show (ReadTooLong expected readBS) = + unlines [ "Read too long:" + , " Expected to read " <> show expected + , " Actually read " <> show (BS.length readBS) <> ": " <> showBS readBS + ] + show (BadStatus status) = + unlines [ "Bad status" + , " Status: " <> showBS status + ] + +-- | Assumes that the interface has already been placed in 'BitMode_MPSSE' +-- using 'setBitMode'. +run :: forall a. InterfaceHandle -> Command a -> IO (Either Failure a) +run ifHnd (Command cmd n parse) = do + let cmd' = BSL.toStrict $ BSB.toLazyByteString cmd + debugLog $ "W ("++show n++"): " ++ showBS cmd' + writer <- async $ FTDI.writeBulk ifHnd cmd' + link writer + let readLoop :: Int -> BS.ByteString -> IO (Either Failure a) + readLoop iters acc + | remain < 0 = return $ Left $ ReadTooLong n acc + | remain == 0 = return $ Right $ parse acc + | otherwise = do + (resp, _readStatus) <- FTDI.readBulk ifHnd (remain+2) + debugLog $ "R " ++ show (BS.length acc) ++ "/" ++ show n ++ ": " ++ showBS resp + let acc' = acc <> BS.drop 2 resp + statusOnly = BS.length resp == 2 + iters' = if statusOnly then iters + 1 else iters + if | BS.take 2 resp == "\xfa" -> return $ Left $ BadStatus resp + | iters == 10 -> return $ Left $ ReadTimedOut cmd' n acc + | otherwise -> readLoop iters' acc' + where remain = n - BS.length acc + + resp <- readLoop 0 mempty + (written, _writeStatus) <- wait writer + return $ if written /= BS.length cmd' + then Left $ WriteTimedOut cmd' written + else resp + +{-# INLINE run #-} + +------------------------------------------------------------------------------- +-- Clocking +------------------------------------------------------------------------------- + +setClockDivisor :: Word16 -> Command () +setClockDivisor n = opCode 0x86 *> word16 n +{-# INLINE setClockDivisor #-} + +-- | The FT232H, FT2232H, and FT4232H can achieve higher data rates if the +-- clock divider is disabled. +disableClkDivBy5 :: Command () +disableClkDivBy5 = opCode 0x8a + +-- | Enable clock divide by 5 to allow for backward compatibility with FT2232D. +enableClkDivBy5 :: Command () +enableClkDivBy5 = opCode 0x8b + +-- | Enables 3 phase data clocking. +-- Used by I2C interfaces to allow data on both clock edges. +enable3PhaseClocking :: Command () +enable3PhaseClocking = opCode 0x8c + +-- | Disables 3 phase data clocking. +disable3PhaseClocking :: Command () +disable3PhaseClocking = opCode 0x8d + +------------------------------------------------------------------------------- +-- Loopback +------------------------------------------------------------------------------- + +enableLoopback :: Command () +enableLoopback = opCode 0x84 +{-# INLINE enableLoopback #-} + +disableLoopback :: Command () +disableLoopback = opCode 0x85 +{-# INLINE disableLoopback #-} + +------------------------------------------------------------------------------- +-- GPIO +------------------------------------------------------------------------------- + +data Gpios a = Gpios { gpio0 :: a -- ^ BankL: TXD, clock + , gpio1 :: a -- ^ BankL: RXD, TDI, MOSI + , gpio2 :: a -- ^ BankL: RTS#, TDO, MISO + , gpio3 :: a -- ^ BankL: CTS#, TMS, CS + , gpio4 :: a + , gpio5 :: a + , gpio6 :: a + , gpio7 :: a + } + deriving (Functor, Foldable, Traversable) + +data Direction i o = Input i | Output o + +data GpioBank = BankL | BankH + +allInputs :: Gpios (Direction () Bool) +allInputs = Gpios i i i i i i i i + where i = Input () + +gpioBits :: Gpios Bool -> Word8 +gpioBits Gpios{..} = + b 0 gpio0 .|. + b 1 gpio1 .|. + b 2 gpio2 .|. + b 3 gpio3 .|. + b 4 gpio4 .|. + b 5 gpio5 .|. + b 6 gpio6 .|. + b 7 gpio7 + where b n True = bit n + b _ False = 0 + +-- | Set the direction and logic state of the pins +setGpioDirValue :: GpioBank -> Gpios (Direction () Bool) -> Command () +setGpioDirValue bank vals = opCode o *> byte valueByte *> byte dirByte + where o = case bank of + BankL -> 0x80 + BankH -> 0x82 + !dirByte = gpioBits $ fmap f vals + where f (Output _) = True + f _ = False + !valueByte = gpioBits $ fmap f vals + where f (Output True) = True + f _ = False + +-- | Read the current state of the pins in the bank and send back 1 byte +getGpioValue :: GpioBank -> Command BS.ByteString +getGpioValue BankL = opCode 0x81 *> readN 1 +getGpioValue BankH = opCode 0x83 *> readN 1 + +------------------------------------------------------------------------------- +-- Transfers +------------------------------------------------------------------------------- + +-- | This will make the chip flush its buffer back to the PC. +flush :: Command () +flush = opCode 0x87 + +waitOnHigh :: Command () +waitOnHigh = opCode 0x88 + +waitOnLow :: Command () +waitOnLow = opCode 0x89 + +data BitOrder = MsbFirst | LsbFirst + +data ClockEdge = Rising | Falling + +otherEdge :: ClockEdge -> ClockEdge +otherEdge Rising = Falling +otherEdge Falling = Rising + +bitOrderBit :: BitOrder -> Word8 +bitOrderBit MsbFirst = 0x0 +bitOrderBit LsbFirst = 0x8 + +outEdgeBit :: ClockEdge -> Word8 +outEdgeBit Rising = 0x0 +outEdgeBit Falling = 0x1 + +inEdgeBit :: ClockEdge -> Word8 +inEdgeBit Rising = 0x0 +inEdgeBit Falling = 0x4 + +writeBytes :: ClockEdge -> BitOrder -> BS.ByteString -> Command () +writeBytes edge order bs + | BS.null bs = error "writeBytes: too short" + | BS.length bs > 0x10000 = error "writeBytes: too long" + | otherwise = + opCode o *> word16 (fromIntegral $ BS.length bs - 1) *> writeByteString bs + where + o = 0x10 .|. bitOrderBit order .|. outEdgeBit edge +{-# INLINE writeBytes #-} + +readBytes :: ClockEdge -> BitOrder -> Int -> Command BS.ByteString +readBytes edge order n + | n == 0 = error "readBytes: too short" + | n > 0x10000 = error "readBytes: too long" + | otherwise = + opCode o + *> word16 (fromIntegral $ n - 1) + *> readN (fromIntegral n) + where + o = 0x20 .|. bitOrderBit order .|. inEdgeBit edge +{-# INLINE readBytes #-} + +readWriteBytes :: ClockEdge -- ^ which edge to clock *out* data on + -> BitOrder -> BS.ByteString -> Command BS.ByteString +readWriteBytes outEdge order bs + | BS.null bs = error "readWriteBytes: too short" + | BS.length bs > 0x10000 = error "readWriteBytes: too long" + | otherwise = + opCode o + *> word16 (fromIntegral $ BS.length bs - 1) + *> transfer (BSB.byteString bs) (BS.length bs) + where + o = 0x30 .|. bitOrderBit order .|. inEdgeBit (otherEdge outEdge) .|. outEdgeBit outEdge +{-# INLINE readWriteBytes #-} diff --git a/System/FTDI/Properties.hs b/System/FTDI/Properties.hs --- a/System/FTDI/Properties.hs +++ b/System/FTDI/Properties.hs @@ -23,10 +23,6 @@ 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 @@ -37,13 +33,14 @@ -- QuickCheck import Test.QuickCheck ( Arbitrary, arbitrary, shrink, choose - , arbitraryBoundedIntegral - , shrinkIntegral, frequency + , frequency ) -- random import System.Random ( Random ) +-- generic-random +import Generic.Random ( genericArbitrary, uniform ) ------------------------------------------------------------------------------- -- Properties @@ -66,7 +63,7 @@ where ignoreBits = first (.&. 0xf0) prop_baudRateError ∷ RealFrac α ⇒ α → (ChipType → BaudRate α → Bool) -prop_baudRateError maxError = \chip baudRate → +prop_baudRateError maxError chip baudRate = let b = nearestBaudRate chip baudRate e = abs (b - baudRate) ÷ baudRate in unBaudRate e ≤ maxError @@ -87,10 +84,6 @@ -- Arbitrary instances ------------------------------------------------------------------------------- -instance Arbitrary Word8 where - arbitrary = arbitraryBoundedIntegral - shrink = shrinkIntegral - deriving instance Random α ⇒ Random (BaudRate α) instance (Random α, Num α, Arbitrary α) ⇒ Arbitrary (BaudRate α) where @@ -102,5 +95,9 @@ ] shrink = map BaudRate ∘ shrink ∘ unBaudRate -$( derive makeArbitrary ''ModemStatus ) -$( derive makeArbitrary ''ChipType ) +instance Arbitrary ModemStatus where + arbitrary = genericArbitrary uniform + +instance Arbitrary ChipType where + arbitrary = genericArbitrary uniform + diff --git a/System/FTDI/Utils.hs b/System/FTDI/Utils.hs --- a/System/FTDI/Utils.hs +++ b/System/FTDI/Utils.hs @@ -16,7 +16,7 @@ import Data.Ord ( Ord, min, max ) import Prelude ( Enum, Bounded, minBound, maxBound , Num, (+), Integral - , fromEnum, fromInteger, fromIntegral + , fromEnum, fromIntegral , divMod ) @@ -34,10 +34,10 @@ genFromEnum ∷ (Enum e, Num n) ⇒ e → n genFromEnum = fromIntegral ∘ fromEnum -orBits ∷ Bits α ⇒ [α] → α +orBits ∷ (Num α, Bits α) ⇒ [α] → α orBits = foldr (.|.) 0 -andBits ∷ Bits α ⇒ [α] → α +andBits ∷ (Num α, Bits α) ⇒ [α] → α andBits = foldr (.&.) $ complement 0 clamp ∷ (Bounded α, Ord α) ⇒ α → α diff --git a/System/FTDI/Utils/Properties.hs b/System/FTDI/Utils/Properties.hs --- a/System/FTDI/Utils/Properties.hs +++ b/System/FTDI/Utils/Properties.hs @@ -6,13 +6,12 @@ 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 + , toInteger, fromIntegral , (+), abs, mod, ceiling, div ) diff --git a/ftdi.cabal b/ftdi.cabal --- a/ftdi.cabal +++ b/ftdi.cabal @@ -1,75 +1,64 @@ name: ftdi -version: 0.2.0.1 -cabal-version: >=1.6 -build-type: Custom +version: 0.3.0.0 +cabal-version: >=1.10 +build-type: Simple stability: experimental -author: Roel van Dijk -maintainer: Roel van Dijk -copyright: (c) 2009, 2010 Roel van Dijk +author: Roel van Dijk , Ben Gamari , David Cox +maintainer: David Cox = 3.0.3 && < 4.3 + build-depends: async >= 2.2 && < 2.3 + , base >= 4.5 && < 4.16 , base-unicode-symbols >= 0.1.1 && < 0.3 - , bytestring >= 0.9.1 && < 0.10 - , safe >= 0.2 && < 0.3 - , transformers >= 0.2 && < 0.3 - , usb >= 0.3 && < 0.4 + , bytestring >= 0.10 && < 0.12 + , transformers >= 0.5 && < 0.6 + , usb >= 1.3 && < 1.4 + , vector >= 0.12 && < 0.13 + default-language: Haskell2010 ghc-options: -Wall - if flag(nolib) - buildable: False - ------------------------------------------------------------------------------- -executable test +test-suite test main-is: test.hs - other-modules: System.FTDI.Internal + type: exitcode-stdio-1.0 + other-modules: System.FTDI + , 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 + default-language: Haskell2010 + build-depends: base + , base-unicode-symbols + , bytestring + , QuickCheck >= 2.11 && < 2.15 + , generic-random >= 1.3 && < 1.4 + , random >= 1.0.0 && < 1.3 + , tagged >= 0.8 && < 0.9 + , test-framework >= 0.8 && < 0.9 + , test-framework-quickcheck2 >= 0.3 && < 0.4 + , transformers + , usb + , vector diff --git a/test.hs b/test.hs --- a/test.hs +++ b/test.hs @@ -7,14 +7,13 @@ -- base import Data.Bool ( Bool ) -import Data.Char ( String ) +import Data.String ( 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 + , RealFrac ) import System.IO ( IO ) import Text.Show ( Show ) @@ -60,12 +59,12 @@ [ 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 "baud rate" +-- [ testGroup "error" +-- [ test_baudRate_error "Float" (0.05 ∷ Float) +-- , test_baudRate_error "Double" (0.05 ∷ Double) +-- ] +-- ] ] , testGroup "utilities" [ testGroup "clamp" @@ -98,27 +97,27 @@ ] ] -test_baudRate_error ∷ ∀ α. (Arbitrary α, Random α, Num α, RealFrac α) ⇒ String → α → Test +test_baudRate_error ∷ ∀ α. (Show α, 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 ∷ ∀ α. (Show α, 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 ∷ ∀ α. (Show α, 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 ∷ ∀ α. (Show α, 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 ∷ ∀ α. (Show α, 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 ∷ ∀ α. (Show α, Arbitrary α, Integral α) ⇒ String → Tagged α Test test_divRndUp_alt2 n = Tagged $ testProperty n (prop_divRndUp2 ∷ α → α → Property)