ftdi 0.2.0.1 → 0.3.0.0

raw patch · 11 files changed

+491/−190 lines, 11 filesdep +asyncdep +generic-randomdep +vectordep −derivedep −safedep ~QuickCheckdep ~basedep ~base-unicode-symbolssetup-changednew-uploaderPVP ok

version bump matches the API change (PVP)

Dependencies added: async, generic-random, vector

Dependencies removed: derive, safe

Dependency ranges changed: QuickCheck, base, base-unicode-symbols, bytestring, random, tagged, test-framework, test-framework-quickcheck2, transformers, usb

API changes (from Hackage documentation)

Files

• CHANGELOG.md +7/−0
• README.md +15/−0
• Setup.hs +2/−51
• System/FTDI.hs +2/−2
• System/FTDI/Internal.hs +59/−58
• System/FTDI/MPSSE.hs +343/−0
• System/FTDI/Properties.hs +10/−13
• System/FTDI/Utils.hs +3/−3
• System/FTDI/Utils/Properties.hs +1/−2
• ftdi.cabal +35/−46
• test.hs +14/−15

@@ -0,0 +1,7 @@+# Revision history for ftdi++## 0.3.0.0 -- 2021-04-10++* Major project update+* MPSSE support+* Additional documentation

@@ -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]:            <https://hackage.haskell.org/package/ftdi>+[hackage-badge]:      <https://img.shields.io/hackage/v/ftdi.svg?color=success>+[hackage-deps-badge]: <https://img.shields.io/hackage-deps/v/ftdi.svg>+[hackage-deps]:       <http://packdeps.haskellers.com/feed?needle=ftdi>

@@ -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

@@ -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

@@ -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)

@@ -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 #-}

@@ -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+

@@ -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 α) ⇒ α → α

@@ -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                      ) 

@@ -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 <vandijk.roel@gmail.com>-maintainer:    Roel van Dijk <vandijk.roel@gmail.com>-copyright:     (c) 2009, 2010 Roel van Dijk+author:        Roel van Dijk <vandijk.roel@gmail.com>, Ben Gamari <ben@smart-cactus.org>, David Cox <standardsemiconductor@gmail.com>+maintainer:    David Cox <standardsemiconductor@gmail.com+copyright:     (c) 2009, 2010 Roel van Dijk, (c) 2018 Ben Gamari, (c) 2021 David Cox license:       BSD3 license-file:  LICENSE-category:      System+category:      System, Hardware 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.+extra-source-files: CHANGELOG.md, README.md  source-repository head-  type:     darcs-  location: http://code.haskell.org/~roelvandijk/code/ftdi+  type:     git+  location: https://github.com/standardsemiconductor/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+                 , System.FTDI.MPSSE   other-modules: System.FTDI.Internal                , System.FTDI.Utils-  build-depends: base                 >= 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

@@ -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)