{-# 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 Control.Monad (void)

import qualified System.FTDI as FTDI
import System.FTDI (InterfaceHandle)
import System.IO

debug :: Bool
debug :: Bool
debug = Bool
False

debugLog :: String -> IO ()
debugLog :: String -> IO ()
debugLog
  | Bool
debug = Handle -> String -> IO ()
hPutStrLn Handle
stderr
  | Bool
otherwise = IO () -> String -> IO ()
forall a b. a -> b -> a
const (IO () -> String -> IO ()) -> IO () -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- Useful for debugging
showBS :: BS.ByteString -> String
showBS :: ByteString -> String
showBS = (Word8 -> String -> String) -> String -> [Word8] -> String
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Word8
n String
rest -> Word8 -> String -> String
forall a. (Integral a, Show a) => a -> String -> String
showHex Word8
n (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String -> String
showChar Char
' ' (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
rest) String
"" ([Word8] -> String)
-> (ByteString -> [Word8]) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Word8]
BS.unpack

data Command a = Command { forall a. Command a -> Builder
command :: BSB.Builder
                         , forall a. Command a -> Int
expectedBytes :: !Int
                         , forall a. Command a -> ByteString -> a
parseBytes :: BS.ByteString -> a
                         }

instance Functor Command where
    fmap :: forall a b. (a -> b) -> Command a -> Command b
fmap a -> b
f (Command Builder
a Int
b ByteString -> a
c) = Builder -> Int -> (ByteString -> b) -> Command b
forall a. Builder -> Int -> (ByteString -> a) -> Command a
Command Builder
a Int
b (a -> b
f (a -> b) -> (ByteString -> a) -> ByteString -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> a
c)
    {-# INLINE fmap #-}

instance Applicative Command where
    pure :: forall a. a -> Command a
pure a
x = Builder -> Int -> (ByteString -> a) -> Command a
forall a. Builder -> Int -> (ByteString -> a) -> Command a
Command Builder
forall a. Monoid a => a
mempty Int
0 (a -> ByteString -> a
forall a b. a -> b -> a
const a
x)
    {-# INLINE pure #-}
    Command Builder
a Int
b ByteString -> a -> b
c <*> :: forall a b. Command (a -> b) -> Command a -> Command b
<*> Command Builder
a' Int
b' ByteString -> a
c' =
        Builder -> Int -> (ByteString -> b) -> Command b
forall a. Builder -> Int -> (ByteString -> a) -> Command a
Command (Builder
a Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
a') (Int
b Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
b') ByteString -> b
parse
      where
        parse :: ByteString -> b
parse ByteString
bs =
            let (ByteString
bs1, ByteString
bs2) = Int -> ByteString -> (ByteString, ByteString)
BS.splitAt Int
b ByteString
bs
            in ByteString -> a -> b
c ByteString
bs1 (ByteString -> a
c' ByteString
bs2)
    {-# INLINE (<*>) #-}

opCode :: Word8 -> Command ()
opCode :: Word8 -> Command ()
opCode = Word8 -> Command ()
byte
{-# INLINE opCode #-}

byte :: Word8 -> Command ()
byte :: Word8 -> Command ()
byte Word8
o = Command ByteString -> Command ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Command ByteString -> Command ())
-> Command ByteString -> Command ()
forall a b. (a -> b) -> a -> b
$ Builder -> Int -> Command ByteString
transfer (Word8 -> Builder
BSB.word8 Word8
o) Int
0
{-# INLINE byte #-}

word16 :: Word16 -> Command ()
word16 :: Word16 -> Command ()
word16 Word16
o = Command ByteString -> Command ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Command ByteString -> Command ())
-> Command ByteString -> Command ()
forall a b. (a -> b) -> a -> b
$ Builder -> Int -> Command ByteString
transfer (Word16 -> Builder
BSB.word16LE Word16
o) Int
0
{-# INLINE word16 #-}

transfer :: BSB.Builder -> Int -> Command BS.ByteString
transfer :: Builder -> Int -> Command ByteString
transfer Builder
b Int
n = Command :: forall a. Builder -> Int -> (ByteString -> a) -> Command a
Command { command :: Builder
command = Builder
b
                       , expectedBytes :: Int
expectedBytes = Int
n
                       , parseBytes :: ByteString -> ByteString
parseBytes = ByteString -> ByteString
forall a. a -> a
id }
{-# INLINE transfer #-}

writeByteString :: BS.ByteString -> Command ()
writeByteString :: ByteString -> Command ()
writeByteString ByteString
bs = Command ByteString -> Command ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Command ByteString -> Command ())
-> Command ByteString -> Command ()
forall a b. (a -> b) -> a -> b
$ Builder -> Int -> Command ByteString
transfer (ByteString -> Builder
BSB.byteString ByteString
bs) Int
0
{-# INLINE writeByteString #-}

readN :: Int -> Command BS.ByteString
readN :: Int -> Command ByteString
readN = Builder -> Int -> Command ByteString
transfer Builder
forall a. Monoid a => a
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 :: Failure -> String
show (WriteTimedOut ByteString
write Int
written) =
        [String] -> String
unlines [ String
"Write timed out:"
                , String
"  Wrote " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
written String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" of " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (ByteString -> Int
BS.length ByteString
write) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
showBS ByteString
write
                ]
    show (ReadTimedOut ByteString
written Int
expected ByteString
readBS) =
        [String] -> String
unlines [ String
"Read timed out:"
                , String
"  Wrote " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (ByteString -> Int
BS.length ByteString
written) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
showBS ByteString
written
                , String
"  Expected to read " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
expected
                , String
"  Actually read " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (ByteString -> Int
BS.length ByteString
readBS) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
showBS ByteString
readBS
                ]
    show (ReadTooLong Int
expected ByteString
readBS) =
        [String] -> String
unlines [ String
"Read too long:"
                , String
"  Expected to read " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
expected
                , String
"  Actually read " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (ByteString -> Int
BS.length ByteString
readBS) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
showBS ByteString
readBS
                ]
    show (BadStatus ByteString
status) =
        [String] -> String
unlines [ String
"Bad status"
                , String
"  Status: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
showBS ByteString
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 :: forall a. InterfaceHandle -> Command a -> IO (Either Failure a)
run InterfaceHandle
ifHnd (Command Builder
cmd Int
n ByteString -> a
parse) = do
    let cmd' :: ByteString
cmd' = ByteString -> ByteString
BSL.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
BSB.toLazyByteString Builder
cmd
    String -> IO ()
debugLog (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"W ("String -> String -> String
forall a. [a] -> [a] -> [a]
++Int -> String
forall a. Show a => a -> String
show Int
nString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"): " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ByteString -> String
showBS ByteString
cmd'
    Async (Int, Status)
writer <- IO (Int, Status) -> IO (Async (Int, Status))
forall a. IO a -> IO (Async a)
async (IO (Int, Status) -> IO (Async (Int, Status)))
-> IO (Int, Status) -> IO (Async (Int, Status))
forall a b. (a -> b) -> a -> b
$ InterfaceHandle -> ByteString -> IO (Int, Status)
FTDI.writeBulk InterfaceHandle
ifHnd ByteString
cmd'
    Async (Int, Status) -> IO ()
forall a. Async a -> IO ()
link Async (Int, Status)
writer
    let readLoop :: Int -> BS.ByteString -> IO (Either Failure a)
        readLoop :: Int -> ByteString -> IO (Either Failure a)
readLoop Int
iters ByteString
acc
          | Int
remain Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0  = Either Failure a -> IO (Either Failure a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Failure a -> IO (Either Failure a))
-> Either Failure a -> IO (Either Failure a)
forall a b. (a -> b) -> a -> b
$ Failure -> Either Failure a
forall a b. a -> Either a b
Left (Failure -> Either Failure a) -> Failure -> Either Failure a
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> Failure
ReadTooLong Int
n ByteString
acc
          | Int
remain Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = Either Failure a -> IO (Either Failure a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Failure a -> IO (Either Failure a))
-> Either Failure a -> IO (Either Failure a)
forall a b. (a -> b) -> a -> b
$ a -> Either Failure a
forall a b. b -> Either a b
Right (a -> Either Failure a) -> a -> Either Failure a
forall a b. (a -> b) -> a -> b
$ ByteString -> a
parse ByteString
acc
          | Bool
otherwise = do
              (ByteString
resp, Status
_readStatus) <- InterfaceHandle -> Int -> IO (ByteString, Status)
FTDI.readBulk InterfaceHandle
ifHnd (Int
remainInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
2)
              String -> IO ()
debugLog (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"R " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (ByteString -> Int
BS.length ByteString
acc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ByteString -> String
showBS ByteString
resp
              let acc' :: ByteString
acc' = ByteString
acc ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Int -> ByteString -> ByteString
BS.drop Int
2 ByteString
resp
                  statusOnly :: Bool
statusOnly = ByteString -> Int
BS.length ByteString
resp Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2
                  iters' :: Int
iters' = if Bool
statusOnly then Int
iters Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 else Int
iters
              if | Int -> ByteString -> ByteString
BS.take Int
2 ByteString
resp ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"\xfa"  -> Either Failure a -> IO (Either Failure a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Failure a -> IO (Either Failure a))
-> Either Failure a -> IO (Either Failure a)
forall a b. (a -> b) -> a -> b
$ Failure -> Either Failure a
forall a b. a -> Either a b
Left (Failure -> Either Failure a) -> Failure -> Either Failure a
forall a b. (a -> b) -> a -> b
$ ByteString -> Failure
BadStatus ByteString
resp
                 | Int
iters Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
10               -> Either Failure a -> IO (Either Failure a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Failure a -> IO (Either Failure a))
-> Either Failure a -> IO (Either Failure a)
forall a b. (a -> b) -> a -> b
$ Failure -> Either Failure a
forall a b. a -> Either a b
Left (Failure -> Either Failure a) -> Failure -> Either Failure a
forall a b. (a -> b) -> a -> b
$ ByteString -> Int -> ByteString -> Failure
ReadTimedOut ByteString
cmd' Int
n ByteString
acc
                 | Bool
otherwise                 -> Int -> ByteString -> IO (Either Failure a)
readLoop Int
iters' ByteString
acc'
          where remain :: Int
remain = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- ByteString -> Int
BS.length ByteString
acc

    Either Failure a
resp <- Int -> ByteString -> IO (Either Failure a)
readLoop Int
0 ByteString
forall a. Monoid a => a
mempty
    (Int
written, Status
_writeStatus) <- Async (Int, Status) -> IO (Int, Status)
forall a. Async a -> IO a
wait Async (Int, Status)
writer
    Either Failure a -> IO (Either Failure a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Failure a -> IO (Either Failure a))
-> Either Failure a -> IO (Either Failure a)
forall a b. (a -> b) -> a -> b
$ if Int
written Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString -> Int
BS.length ByteString
cmd'
      then Failure -> Either Failure a
forall a b. a -> Either a b
Left (Failure -> Either Failure a) -> Failure -> Either Failure a
forall a b. (a -> b) -> a -> b
$ ByteString -> Int -> Failure
WriteTimedOut ByteString
cmd' Int
written
      else Either Failure a
resp

{-# INLINE run #-}

-------------------------------------------------------------------------------
-- Clocking
-------------------------------------------------------------------------------

setClockDivisor :: Word16 -> Command ()
setClockDivisor :: Word16 -> Command ()
setClockDivisor Word16
n = Word8 -> Command ()
opCode Word8
0x86 Command () -> Command () -> Command ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Word16 -> Command ()
word16 Word16
n
{-# INLINE setClockDivisor #-}

-- | The FT232H, FT2232H, and FT4232H can achieve higher data rates if the
-- clock divider is disabled.
disableClkDivBy5 :: Command ()
disableClkDivBy5 :: Command ()
disableClkDivBy5 = Word8 -> Command ()
opCode Word8
0x8a

-- | Enable clock divide by 5 to allow for backward compatibility with FT2232D.
enableClkDivBy5 :: Command ()
enableClkDivBy5 :: Command ()
enableClkDivBy5 = Word8 -> Command ()
opCode Word8
0x8b

-- | Enables 3 phase data clocking.
-- Used by I2C interfaces to allow data on both clock edges.
enable3PhaseClocking :: Command ()
enable3PhaseClocking :: Command ()
enable3PhaseClocking = Word8 -> Command ()
opCode Word8
0x8c

-- | Disables 3 phase data clocking.
disable3PhaseClocking :: Command ()
disable3PhaseClocking :: Command ()
disable3PhaseClocking = Word8 -> Command ()
opCode Word8
0x8d

-------------------------------------------------------------------------------
-- Loopback
-------------------------------------------------------------------------------

enableLoopback :: Command ()
enableLoopback :: Command ()
enableLoopback = Word8 -> Command ()
opCode Word8
0x84
{-# INLINE enableLoopback #-}

disableLoopback :: Command ()
disableLoopback :: Command ()
disableLoopback = Word8 -> Command ()
opCode Word8
0x85
{-# INLINE disableLoopback #-}

-------------------------------------------------------------------------------
-- GPIO
-------------------------------------------------------------------------------

data Gpios a = Gpios { forall a. Gpios a -> a
gpio0 :: a  -- ^ BankL: TXD, clock
                     , forall a. Gpios a -> a
gpio1 :: a  -- ^ BankL: RXD, TDI, MOSI
                     , forall a. Gpios a -> a
gpio2 :: a  -- ^ BankL: RTS#, TDO, MISO
                     , forall a. Gpios a -> a
gpio3 :: a  -- ^ BankL: CTS#, TMS, CS
                     , forall a. Gpios a -> a
gpio4 :: a
                     , forall a. Gpios a -> a
gpio5 :: a
                     , forall a. Gpios a -> a
gpio6 :: a
                     , forall a. Gpios a -> a
gpio7 :: a
                     }
             deriving ((forall a b. (a -> b) -> Gpios a -> Gpios b)
-> (forall a b. a -> Gpios b -> Gpios a) -> Functor Gpios
forall a b. a -> Gpios b -> Gpios a
forall a b. (a -> b) -> Gpios a -> Gpios b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Gpios b -> Gpios a
$c<$ :: forall a b. a -> Gpios b -> Gpios a
fmap :: forall a b. (a -> b) -> Gpios a -> Gpios b
$cfmap :: forall a b. (a -> b) -> Gpios a -> Gpios b
Functor, (forall m. Monoid m => Gpios m -> m)
-> (forall m a. Monoid m => (a -> m) -> Gpios a -> m)
-> (forall m a. Monoid m => (a -> m) -> Gpios a -> m)
-> (forall a b. (a -> b -> b) -> b -> Gpios a -> b)
-> (forall a b. (a -> b -> b) -> b -> Gpios a -> b)
-> (forall b a. (b -> a -> b) -> b -> Gpios a -> b)
-> (forall b a. (b -> a -> b) -> b -> Gpios a -> b)
-> (forall a. (a -> a -> a) -> Gpios a -> a)
-> (forall a. (a -> a -> a) -> Gpios a -> a)
-> (forall a. Gpios a -> [a])
-> (forall a. Gpios a -> Bool)
-> (forall a. Gpios a -> Int)
-> (forall a. Eq a => a -> Gpios a -> Bool)
-> (forall a. Ord a => Gpios a -> a)
-> (forall a. Ord a => Gpios a -> a)
-> (forall a. Num a => Gpios a -> a)
-> (forall a. Num a => Gpios a -> a)
-> Foldable Gpios
forall a. Eq a => a -> Gpios a -> Bool
forall a. Num a => Gpios a -> a
forall a. Ord a => Gpios a -> a
forall m. Monoid m => Gpios m -> m
forall a. Gpios a -> Bool
forall a. Gpios a -> Int
forall a. Gpios a -> [a]
forall a. (a -> a -> a) -> Gpios a -> a
forall m a. Monoid m => (a -> m) -> Gpios a -> m
forall b a. (b -> a -> b) -> b -> Gpios a -> b
forall a b. (a -> b -> b) -> b -> Gpios a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: forall a. Num a => Gpios a -> a
$cproduct :: forall a. Num a => Gpios a -> a
sum :: forall a. Num a => Gpios a -> a
$csum :: forall a. Num a => Gpios a -> a
minimum :: forall a. Ord a => Gpios a -> a
$cminimum :: forall a. Ord a => Gpios a -> a
maximum :: forall a. Ord a => Gpios a -> a
$cmaximum :: forall a. Ord a => Gpios a -> a
elem :: forall a. Eq a => a -> Gpios a -> Bool
$celem :: forall a. Eq a => a -> Gpios a -> Bool
length :: forall a. Gpios a -> Int
$clength :: forall a. Gpios a -> Int
null :: forall a. Gpios a -> Bool
$cnull :: forall a. Gpios a -> Bool
toList :: forall a. Gpios a -> [a]
$ctoList :: forall a. Gpios a -> [a]
foldl1 :: forall a. (a -> a -> a) -> Gpios a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Gpios a -> a
foldr1 :: forall a. (a -> a -> a) -> Gpios a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> Gpios a -> a
foldl' :: forall b a. (b -> a -> b) -> b -> Gpios a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> Gpios a -> b
foldl :: forall b a. (b -> a -> b) -> b -> Gpios a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> Gpios a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> Gpios a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> Gpios a -> b
foldr :: forall a b. (a -> b -> b) -> b -> Gpios a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> Gpios a -> b
foldMap' :: forall m a. Monoid m => (a -> m) -> Gpios a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> Gpios a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> Gpios a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Gpios a -> m
fold :: forall m. Monoid m => Gpios m -> m
$cfold :: forall m. Monoid m => Gpios m -> m
Foldable, Functor Gpios
Foldable Gpios
Functor Gpios
-> Foldable Gpios
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> Gpios a -> f (Gpios b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    Gpios (f a) -> f (Gpios a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> Gpios a -> m (Gpios b))
-> (forall (m :: * -> *) a. Monad m => Gpios (m a) -> m (Gpios a))
-> Traversable Gpios
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a. Monad m => Gpios (m a) -> m (Gpios a)
forall (f :: * -> *) a. Applicative f => Gpios (f a) -> f (Gpios a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Gpios a -> m (Gpios b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Gpios a -> f (Gpios b)
sequence :: forall (m :: * -> *) a. Monad m => Gpios (m a) -> m (Gpios a)
$csequence :: forall (m :: * -> *) a. Monad m => Gpios (m a) -> m (Gpios a)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Gpios a -> m (Gpios b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Gpios a -> m (Gpios b)
sequenceA :: forall (f :: * -> *) a. Applicative f => Gpios (f a) -> f (Gpios a)
$csequenceA :: forall (f :: * -> *) a. Applicative f => Gpios (f a) -> f (Gpios a)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Gpios a -> f (Gpios b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Gpios a -> f (Gpios b)
Traversable)

data Direction i o = Input i | Output o

data GpioBank = BankL | BankH

allInputs :: Gpios (Direction () Bool)
allInputs :: Gpios (Direction () Bool)
allInputs = Direction () Bool
-> Direction () Bool
-> Direction () Bool
-> Direction () Bool
-> Direction () Bool
-> Direction () Bool
-> Direction () Bool
-> Direction () Bool
-> Gpios (Direction () Bool)
forall a. a -> a -> a -> a -> a -> a -> a -> a -> Gpios a
Gpios Direction () Bool
forall {o}. Direction () o
i Direction () Bool
forall {o}. Direction () o
i Direction () Bool
forall {o}. Direction () o
i Direction () Bool
forall {o}. Direction () o
i Direction () Bool
forall {o}. Direction () o
i Direction () Bool
forall {o}. Direction () o
i Direction () Bool
forall {o}. Direction () o
i Direction () Bool
forall {o}. Direction () o
i
  where i :: Direction () o
i = () -> Direction () o
forall i o. i -> Direction i o
Input ()

gpioBits :: Gpios Bool -> Word8
gpioBits :: Gpios Bool -> Word8
gpioBits Gpios{Bool
gpio7 :: Bool
gpio6 :: Bool
gpio5 :: Bool
gpio4 :: Bool
gpio3 :: Bool
gpio2 :: Bool
gpio1 :: Bool
gpio0 :: Bool
gpio7 :: forall a. Gpios a -> a
gpio6 :: forall a. Gpios a -> a
gpio5 :: forall a. Gpios a -> a
gpio4 :: forall a. Gpios a -> a
gpio3 :: forall a. Gpios a -> a
gpio2 :: forall a. Gpios a -> a
gpio1 :: forall a. Gpios a -> a
gpio0 :: forall a. Gpios a -> a
..} =
    Int -> Bool -> Word8
forall {a}. (Bits a, Num a) => Int -> Bool -> a
b Int
0 Bool
gpio0 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|.
    Int -> Bool -> Word8
forall {a}. (Bits a, Num a) => Int -> Bool -> a
b Int
1 Bool
gpio1 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|.
    Int -> Bool -> Word8
forall {a}. (Bits a, Num a) => Int -> Bool -> a
b Int
2 Bool
gpio2 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|.
    Int -> Bool -> Word8
forall {a}. (Bits a, Num a) => Int -> Bool -> a
b Int
3 Bool
gpio3 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|.
    Int -> Bool -> Word8
forall {a}. (Bits a, Num a) => Int -> Bool -> a
b Int
4 Bool
gpio4 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|.
    Int -> Bool -> Word8
forall {a}. (Bits a, Num a) => Int -> Bool -> a
b Int
5 Bool
gpio5 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|.
    Int -> Bool -> Word8
forall {a}. (Bits a, Num a) => Int -> Bool -> a
b Int
6 Bool
gpio6 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|.
    Int -> Bool -> Word8
forall {a}. (Bits a, Num a) => Int -> Bool -> a
b Int
7 Bool
gpio7
  where b :: Int -> Bool -> a
b Int
n Bool
True  = Int -> a
forall a. Bits a => Int -> a
bit Int
n
        b Int
_ Bool
False = a
0

-- | Set the direction and logic state of the pins
setGpioDirValue :: GpioBank -> Gpios (Direction () Bool) -> Command ()
setGpioDirValue :: GpioBank -> Gpios (Direction () Bool) -> Command ()
setGpioDirValue GpioBank
bank Gpios (Direction () Bool)
vals = Word8 -> Command ()
opCode Word8
o Command () -> Command () -> Command ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Word8 -> Command ()
byte Word8
valueByte Command () -> Command () -> Command ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Word8 -> Command ()
byte Word8
dirByte
  where o :: Word8
o = case GpioBank
bank of
              GpioBank
BankL -> Word8
0x80
              GpioBank
BankH -> Word8
0x82
        !dirByte :: Word8
dirByte = Gpios Bool -> Word8
gpioBits (Gpios Bool -> Word8) -> Gpios Bool -> Word8
forall a b. (a -> b) -> a -> b
$ (Direction () Bool -> Bool)
-> Gpios (Direction () Bool) -> Gpios Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Direction () Bool -> Bool
forall {i} {o}. Direction i o -> Bool
f Gpios (Direction () Bool)
vals
          where f :: Direction i o -> Bool
f (Output o
_) = Bool
True
                f Direction i o
_          = Bool
False
        !valueByte :: Word8
valueByte = Gpios Bool -> Word8
gpioBits (Gpios Bool -> Word8) -> Gpios Bool -> Word8
forall a b. (a -> b) -> a -> b
$ (Direction () Bool -> Bool)
-> Gpios (Direction () Bool) -> Gpios Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Direction () Bool -> Bool
forall {i}. Direction i Bool -> Bool
f Gpios (Direction () Bool)
vals
          where f :: Direction i Bool -> Bool
f (Output Bool
True) = Bool
True
                f Direction i Bool
_             = Bool
False

-- | Read the current state of the pins in the bank and send back 1 byte
getGpioValue :: GpioBank -> Command BS.ByteString
getGpioValue :: GpioBank -> Command ByteString
getGpioValue GpioBank
BankL = Word8 -> Command ()
opCode Word8
0x81 Command () -> Command ByteString -> Command ByteString
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Int -> Command ByteString
readN Int
1
getGpioValue GpioBank
BankH = Word8 -> Command ()
opCode Word8
0x83 Command () -> Command ByteString -> Command ByteString
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Int -> Command ByteString
readN Int
1

-------------------------------------------------------------------------------
-- Transfers
-------------------------------------------------------------------------------

-- | This will make the chip flush its buffer back to the PC.
flush :: Command ()
flush :: Command ()
flush = Word8 -> Command ()
opCode Word8
0x87

waitOnHigh :: Command ()
waitOnHigh :: Command ()
waitOnHigh = Word8 -> Command ()
opCode Word8
0x88

waitOnLow :: Command ()
waitOnLow :: Command ()
waitOnLow = Word8 -> Command ()
opCode Word8
0x89

data BitOrder = MsbFirst | LsbFirst

data ClockEdge = Rising | Falling

otherEdge :: ClockEdge -> ClockEdge
otherEdge :: ClockEdge -> ClockEdge
otherEdge ClockEdge
Rising  = ClockEdge
Falling
otherEdge ClockEdge
Falling = ClockEdge
Rising

bitOrderBit :: BitOrder -> Word8
bitOrderBit :: BitOrder -> Word8
bitOrderBit BitOrder
MsbFirst = Word8
0x0
bitOrderBit BitOrder
LsbFirst = Word8
0x8

outEdgeBit :: ClockEdge -> Word8
outEdgeBit :: ClockEdge -> Word8
outEdgeBit ClockEdge
Rising  = Word8
0x0
outEdgeBit ClockEdge
Falling = Word8
0x1

inEdgeBit :: ClockEdge -> Word8
inEdgeBit :: ClockEdge -> Word8
inEdgeBit ClockEdge
Rising  = Word8
0x0
inEdgeBit ClockEdge
Falling = Word8
0x4

writeBytes :: ClockEdge -> BitOrder -> BS.ByteString -> Command ()
writeBytes :: ClockEdge -> BitOrder -> ByteString -> Command ()
writeBytes ClockEdge
edge BitOrder
order ByteString
bs
  | ByteString -> Bool
BS.null ByteString
bs = String -> Command ()
forall a. HasCallStack => String -> a
error String
"writeBytes: too short"
  | ByteString -> Int
BS.length ByteString
bs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0x10000 = String -> Command ()
forall a. HasCallStack => String -> a
error String
"writeBytes: too long"
  | Bool
otherwise =
    Word8 -> Command ()
opCode Word8
o Command () -> Command () -> Command ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Word16 -> Command ()
word16 (Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word16) -> Int -> Word16
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
BS.length ByteString
bs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Command () -> Command () -> Command ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ByteString -> Command ()
writeByteString ByteString
bs
  where
    o :: Word8
o = Word8
0x10 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. BitOrder -> Word8
bitOrderBit BitOrder
order Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. ClockEdge -> Word8
outEdgeBit ClockEdge
edge
{-# INLINE writeBytes #-}

readBytes :: ClockEdge -> BitOrder -> Int -> Command BS.ByteString
readBytes :: ClockEdge -> BitOrder -> Int -> Command ByteString
readBytes ClockEdge
edge BitOrder
order Int
n
  | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = String -> Command ByteString
forall a. HasCallStack => String -> a
error String
"readBytes: too short"
  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0x10000 = String -> Command ByteString
forall a. HasCallStack => String -> a
error String
"readBytes: too long"
  | Bool
otherwise =
    Word8 -> Command ()
opCode Word8
o
    Command () -> Command () -> Command ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Word16 -> Command ()
word16 (Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word16) -> Int -> Word16
forall a b. (a -> b) -> a -> b
$ Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
    Command () -> Command ByteString -> Command ByteString
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Int -> Command ByteString
readN (Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n)
  where
    o :: Word8
o = Word8
0x20 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. BitOrder -> Word8
bitOrderBit BitOrder
order Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. ClockEdge -> Word8
inEdgeBit ClockEdge
edge
{-# INLINE readBytes #-}

readWriteBytes :: ClockEdge  -- ^ which edge to clock *out* data on
               -> BitOrder -> BS.ByteString -> Command BS.ByteString
readWriteBytes :: ClockEdge -> BitOrder -> ByteString -> Command ByteString
readWriteBytes ClockEdge
outEdge BitOrder
order ByteString
bs
  | ByteString -> Bool
BS.null ByteString
bs = String -> Command ByteString
forall a. HasCallStack => String -> a
error String
"readWriteBytes: too short"
  | ByteString -> Int
BS.length ByteString
bs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0x10000 = String -> Command ByteString
forall a. HasCallStack => String -> a
error String
"readWriteBytes: too long"
  | Bool
otherwise =
    Word8 -> Command ()
opCode Word8
o
    Command () -> Command () -> Command ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Word16 -> Command ()
word16 (Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word16) -> Int -> Word16
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
BS.length ByteString
bs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
    Command () -> Command ByteString -> Command ByteString
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Builder -> Int -> Command ByteString
transfer (ByteString -> Builder
BSB.byteString ByteString
bs) (ByteString -> Int
BS.length ByteString
bs)
  where
    o :: Word8
o = Word8
0x30 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. BitOrder -> Word8
bitOrderBit BitOrder
order Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. ClockEdge -> Word8
inEdgeBit (ClockEdge -> ClockEdge
otherEdge ClockEdge
outEdge) Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. ClockEdge -> Word8
outEdgeBit ClockEdge
outEdge
{-# INLINE readWriteBytes #-}