-------------------------------------------------------------------------------
-- |
-- Module      :  System.Hardware.Arduino.Comm
-- Copyright   :  (c) Levent Erkok
-- License     :  BSD3
-- Maintainer  :  erkokl@gmail.com
-- Stability   :  experimental
--
-- Basic serial communication routines
-------------------------------------------------------------------------------

{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE ScopedTypeVariables #-}

{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}

module System.Hardware.Arduino.Comm where

import Control.Monad        (when, forever)
import Control.Concurrent   (MVar, ThreadId, newChan, newMVar, newEmptyMVar, putMVar, writeChan, readChan, forkIO, modifyMVar_, tryTakeMVar, killThread)
import Control.Exception    (tryJust, AsyncException(UserInterrupt), handle, SomeException)
import Control.Monad.State  (runStateT, gets, liftIO, modify)
import Data.Bits            (testBit, (.&.))
import Data.List            (intercalate, isInfixOf)
import Data.Maybe           (listToMaybe)
import Data.Word            (Word8)
import System.Timeout       (timeout)
import System.IO            (stderr, hPutStrLn)

import qualified Data.ByteString            as B (unpack, length)
import qualified Data.Map                   as M (empty, mapWithKey, insert, assocs, lookup)
import qualified Data.Set                   as S (empty)
import qualified System.Hardware.Serialport as S (withSerial, defaultSerialSettings, CommSpeed(CS57600), commSpeed, recv, send)

import System.Hardware.Arduino.Data
import System.Hardware.Arduino.Utils
import System.Hardware.Arduino.Protocol

-- | Run the Haskell program to control the board:
--
--    * The file path argument should point to the device file that is
--      associated with the board. (@COM1@ on Windows,
--      @/dev/cu.usbmodemFD131@ on Mac, etc.)
--
--    * The boolean argument controls verbosity. It should remain
--      'False' unless you have communication issues. The print-out
--      is typically less-than-useful, but it might point to the root
--      cause of the problem.
--
-- See "System.Hardware.Arduino.Examples.Blink" for a simple example.
withArduino :: Bool       -- ^ If 'True', debugging info will be printed
            -> FilePath   -- ^ Path to the USB port
            -> Arduino () -- ^ The Haskell controller program to run
            -> IO ()
withArduino :: Bool -> FilePath -> Arduino () -> IO ()
withArduino Bool
verbose FilePath
fp Arduino ()
program =
        do FilePath -> IO ()
debugger <- Bool -> IO (FilePath -> IO ())
mkDebugPrinter Bool
verbose
           FilePath -> IO ()
debugger forall a b. (a -> b) -> a -> b
$ FilePath
"Accessing arduino located at: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show FilePath
fp
           MVar ThreadId
lTid <- forall a. IO (MVar a)
newEmptyMVar
           let Arduino StateT ArduinoState IO ()
controller = do Bool
initOK <- MVar ThreadId -> Arduino Bool
initialize MVar ThreadId
lTid
                                       if Bool
initOK
                                          then Arduino ()
program
                                          else forall a. HasCallStack => FilePath -> a
error FilePath
"Communication time-out (5s) expired."
           forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle (\(SomeException
e::SomeException) -> do MVar ThreadId -> IO ()
cleanUp MVar ThreadId
lTid
                                             let selfErr :: Bool
selfErr = FilePath
"*** hArduino" forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` forall a. Show a => a -> FilePath
show SomeException
e
                                             Handle -> FilePath -> IO ()
hPutStrLn Handle
stderr forall a b. (a -> b) -> a -> b
$ if Bool
selfErr
                                                                then forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Eq a => a -> a -> Bool
== Char
'\n') (forall a. Show a => a -> FilePath
show SomeException
e)
                                                                else FilePath
"*** hArduino:ERROR: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show SomeException
e
                                                                     forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (FilePath
"\n*** " forall a. [a] -> [a] -> [a]
++) [ FilePath
"Make sure your Arduino is connected to " forall a. [a] -> [a] -> [a]
++ FilePath
fp
                                                                                                , FilePath
"And StandardFirmata is running on it!"
                                                                                                ]) forall a b. (a -> b) -> a -> b
$
             forall a.
FilePath -> SerialPortSettings -> (SerialPort -> IO a) -> IO a
S.withSerial FilePath
fp SerialPortSettings
S.defaultSerialSettings{commSpeed :: CommSpeed
S.commSpeed = CommSpeed
S.CS57600} forall a b. (a -> b) -> a -> b
$ \SerialPort
curPort -> do
                let initBoardState :: BoardState
initBoardState = BoardState {
                                         boardCapabilities :: BoardCapabilities
boardCapabilities    = Map IPin PinCapabilities -> BoardCapabilities
BoardCapabilities forall k a. Map k a
M.empty
                                       , analogReportingPins :: Set IPin
analogReportingPins  = forall a. Set a
S.empty
                                       , digitalReportingPins :: Set IPin
digitalReportingPins = forall a. Set a
S.empty
                                       , pinStates :: Map IPin PinData
pinStates            = forall k a. Map k a
M.empty
                                       , digitalWakeUpQueue :: [MVar ()]
digitalWakeUpQueue   = []
                                       , lcds :: Map LCD LCDData
lcds                 = forall k a. Map k a
M.empty
                                     }
                MVar BoardState
bs <- forall a. a -> IO (MVar a)
newMVar BoardState
initBoardState
                Chan Response
dc <- forall a. IO (Chan a)
newChan
                let initState :: ArduinoState
initState = ArduinoState {
                                   message :: FilePath -> IO ()
message       = FilePath -> IO ()
debugger
                                 , bailOut :: FilePath -> [FilePath] -> IO ()
bailOut       = forall {b}. MVar ThreadId -> FilePath -> [FilePath] -> IO b
bailOutF MVar ThreadId
lTid
                                 , port :: SerialPort
port          = SerialPort
curPort
                                 , firmataID :: FilePath
firmataID     = FilePath
"Unknown"
                                 , capabilities :: BoardCapabilities
capabilities  = Map IPin PinCapabilities -> BoardCapabilities
BoardCapabilities forall k a. Map k a
M.empty
                                 , boardState :: MVar BoardState
boardState    = MVar BoardState
bs
                                 , deviceChannel :: Chan Response
deviceChannel = Chan Response
dc
                                 , listenerTid :: MVar ThreadId
listenerTid   = MVar ThreadId
lTid
                              }
                Either () ((), ArduinoState)
res <- forall e b a.
Exception e =>
(e -> Maybe b) -> IO a -> IO (Either b a)
tryJust AsyncException -> Maybe ()
catchCtrlC forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT StateT ArduinoState IO ()
controller ArduinoState
initState
                case Either () ((), ArduinoState)
res of
                  Left () -> FilePath -> IO ()
putStrLn FilePath
"hArduino: Caught Ctrl-C, quitting.."
                  Either () ((), ArduinoState)
_       -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
                MVar ThreadId -> IO ()
cleanUp MVar ThreadId
lTid
 where catchCtrlC :: AsyncException -> Maybe ()
catchCtrlC AsyncException
UserInterrupt = forall a. a -> Maybe a
Just ()
       catchCtrlC AsyncException
_             = forall a. Maybe a
Nothing

       cleanUp :: MVar ThreadId -> IO ()
cleanUp MVar ThreadId
tid = do Maybe ThreadId
mbltid <- forall a. MVar a -> IO (Maybe a)
tryTakeMVar MVar ThreadId
tid
                        forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) ThreadId -> IO ()
killThread Maybe ThreadId
mbltid

       bailOutF :: MVar ThreadId -> FilePath -> [FilePath] -> IO b
bailOutF MVar ThreadId
tid FilePath
m [FilePath]
ms = do MVar ThreadId -> IO ()
cleanUp MVar ThreadId
tid
                              forall a. HasCallStack => FilePath -> a
error forall a b. (a -> b) -> a -> b
$ FilePath
"\n*** hArduino:ERROR: " forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate FilePath
"\n*** " (FilePath
mforall a. a -> [a] -> [a]
:[FilePath]
ms)

-- | Send down a request.
send :: Request -> Arduino ()
send :: Request -> Arduino ()
send Request
req = do FilePath -> Arduino ()
debug forall a b. (a -> b) -> a -> b
$ FilePath
"Sending: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show Request
req forall a. [a] -> [a] -> [a]
++ FilePath
" <" forall a. [a] -> [a] -> [a]
++ [FilePath] -> FilePath
unwords (forall a b. (a -> b) -> [a] -> [b]
map Word8 -> FilePath
showByte (ByteString -> [Word8]
B.unpack ByteString
p)) forall a. [a] -> [a] -> [a]
++ FilePath
">"
              SerialPort
serial <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ArduinoState -> SerialPort
port
              Int
sent <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ SerialPort -> ByteString -> IO Int
S.send SerialPort
serial ByteString
p
              forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
sent forall a. Eq a => a -> a -> Bool
/= Int
lp)
                   (FilePath -> Arduino ()
debug forall a b. (a -> b) -> a -> b
$ FilePath
"Send failed. Tried: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show Int
lp forall a. [a] -> [a] -> [a]
++ FilePath
"bytes, reported: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show Int
sent)
   where p :: ByteString
p  = Request -> ByteString
package Request
req
         lp :: Int
lp = ByteString -> Int
B.length ByteString
p

-- | Receive a sys-ex response. This is a blocking call.
recv :: Arduino Response
recv :: Arduino Response
recv = do Chan Response
ch <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ArduinoState -> Chan Response
deviceChannel
          forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Chan a -> IO a
readChan Chan Response
ch

-- | Receive a sys-ex response with time-out. This is a blocking call, and will wait until
-- either the time-out expires or the message is received
recvTimeOut :: Int -> Arduino (Maybe Response)
recvTimeOut :: Int -> Arduino (Maybe Response)
recvTimeOut Int
n = do Chan Response
ch <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ArduinoState -> Chan Response
deviceChannel
                   forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Int -> IO a -> IO (Maybe a)
timeout Int
n (forall a. Chan a -> IO a
readChan Chan Response
ch)

-- | Start a thread to listen to the board and populate the channel with incoming queries.
setupListener :: Arduino ThreadId
setupListener :: Arduino ThreadId
setupListener = do
        SerialPort
serial <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ArduinoState -> SerialPort
port
        FilePath -> IO ()
dbg    <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ArduinoState -> FilePath -> IO ()
message
        Chan Response
chan   <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ArduinoState -> Chan Response
deviceChannel
        let getBytes :: Int -> IO [Word8]
getBytes Int
n = do let go :: Int -> [ByteString] -> IO [ByteString]
go Int
need [ByteString]
sofar
                                 | Int
need forall a. Ord a => a -> a -> Bool
<= Int
0  = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse [ByteString]
sofar
                                 | Bool
True       = do ByteString
b <- SerialPort -> Int -> IO ByteString
S.recv SerialPort
serial Int
need
                                                   case ByteString -> Int
B.length ByteString
b of
                                                     Int
0 -> Int -> [ByteString] -> IO [ByteString]
go Int
need [ByteString]
sofar
                                                     Int
l -> Int -> [ByteString] -> IO [ByteString]
go (Int
need forall a. Num a => a -> a -> a
- Int
l) (ByteString
b forall a. a -> [a] -> [a]
: [ByteString]
sofar)
                            [ByteString]
chunks <- Int -> [ByteString] -> IO [ByteString]
go Int
n []
                            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ByteString -> [Word8]
B.unpack [ByteString]
chunks
            collectSysEx :: [Word8] -> IO [Word8]
collectSysEx [Word8]
sofar = do [Word8
b] <- Int -> IO [Word8]
getBytes Int
1
                                    if Word8
b forall a. Eq a => a -> a -> Bool
== FirmataCmd -> Word8
firmataCmdVal FirmataCmd
END_SYSEX
                                       then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse [Word8]
sofar
                                       else [Word8] -> IO [Word8]
collectSysEx (Word8
b forall a. a -> [a] -> [a]
: [Word8]
sofar)
            listener :: MVar BoardState -> IO ()
listener MVar BoardState
bs = do
                [Word8
cmd] <- Int -> IO [Word8]
getBytes Int
1
                Response
resp  <- case Word8 -> Either Word8 FirmataCmd
getFirmataCmd Word8
cmd of
                           Left  Word8
unknown     -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Maybe FilePath -> [Word8] -> Response
Unimplemented (forall a. a -> Maybe a
Just (forall a. Show a => a -> FilePath
show Word8
unknown)) []
                           Right FirmataCmd
START_SYSEX -> [Word8] -> Response
unpackageSysEx forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` [Word8] -> IO [Word8]
collectSysEx []
                           Right FirmataCmd
nonSysEx    -> (Int -> IO [Word8]) -> FirmataCmd -> IO Response
unpackageNonSysEx Int -> IO [Word8]
getBytes FirmataCmd
nonSysEx
                case Response
resp of
                  Unimplemented{}      -> FilePath -> IO ()
dbg forall a b. (a -> b) -> a -> b
$ FilePath
"Ignoring the received response: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show Response
resp
                  -- NB. When Firmata sends back AnalogMessage, it uses the number in A0-A1-A2, etc., i.e., 0-1-2; which we
                  -- need to properly interpret in our own pin mapping schema, where analogs come after digitals.
                  AnalogMessage IPin
mp Word8
l Word8
h -> forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar BoardState
bs forall a b. (a -> b) -> a -> b
$ \BoardState
bst ->
                                           do let BoardCapabilities Map IPin PinCapabilities
caps = BoardState -> BoardCapabilities
boardCapabilities BoardState
bst
                                                  mbP :: Maybe IPin
mbP = forall a. [a] -> Maybe a
listToMaybe [IPin
mappedPin | (IPin
mappedPin, PinCapabilities{analogPinNumber :: PinCapabilities -> Maybe Word8
analogPinNumber = Just Word8
mp'}) <- forall k a. Map k a -> [(k, a)]
M.assocs Map IPin PinCapabilities
caps, IPin -> Word8
pinNo IPin
mp forall a. Eq a => a -> a -> Bool
== Word8
mp']
                                              case Maybe IPin
mbP of
                                                Maybe IPin
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return BoardState
bst -- Mapping hasn't happened yet
                                                Just IPin
p  -> do
                                                   let v :: Int
v = (Int
128 forall a. Num a => a -> a -> a
* forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8
h forall a. Bits a => a -> a -> a
.&. Word8
0x07) forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8
l forall a. Bits a => a -> a -> a
.&. Word8
0x7f)) :: Int
                                                   case PinData -> Maybe (Either Bool Int)
pinValue forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (IPin
p forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` BoardState -> Map IPin PinData
pinStates BoardState
bst) of
                                                     Just (Just (Right Int
v'))
                                                       | forall a. Num a => a -> a
abs (Int
v forall a. Num a => a -> a -> a
- Int
v') forall a. Ord a => a -> a -> Bool
< Int
10  -> forall (m :: * -> *) a. Monad m => a -> m a
return () -- be quiet, otherwise prints too much
                                                     Maybe (Maybe (Either Bool Int))
_                      -> FilePath -> IO ()
dbg forall a b. (a -> b) -> a -> b
$ FilePath
"Updating analog pin " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show IPin
p forall a. [a] -> [a] -> [a]
++ FilePath
" values with " forall a. [a] -> [a] -> [a]
++ [Word8] -> FilePath
showByteList [Word8
l,Word8
h] forall a. [a] -> [a] -> [a]
++ FilePath
" (" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show Int
v forall a. [a] -> [a] -> [a]
++ FilePath
")"
                                                   forall (m :: * -> *) a. Monad m => a -> m a
return BoardState
bst{ pinStates :: Map IPin PinData
pinStates = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert IPin
p PinData{pinMode :: PinMode
pinMode = PinMode
ANALOG, pinValue :: Maybe (Either Bool Int)
pinValue = forall a. a -> Maybe a
Just (forall a b. b -> Either a b
Right Int
v)} (BoardState -> Map IPin PinData
pinStates BoardState
bst) }
                  DigitalMessage Port
p Word8
l Word8
h -> do FilePath -> IO ()
dbg forall a b. (a -> b) -> a -> b
$ FilePath
"Updating digital port " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show Port
p forall a. [a] -> [a] -> [a]
++ FilePath
" values with " forall a. [a] -> [a] -> [a]
++ [Word8] -> FilePath
showByteList [Word8
l,Word8
h]
                                             forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar BoardState
bs forall a b. (a -> b) -> a -> b
$ \BoardState
bst -> do
                                                  let upd :: IPin -> PinData -> PinData
upd IPin
o PinData
od | Port
p forall a. Eq a => a -> a -> Bool
/= IPin -> Port
pinPort IPin
o      = PinData
od   -- different port, no change
                                                               | PinData -> PinMode
pinMode PinData
od forall a. Eq a => a -> a -> Bool
/= PinMode
INPUT = PinData
od   -- not an input pin, ignore
                                                               | Bool
True                = PinData
od{pinValue :: Maybe (Either Bool Int)
pinValue = forall a. a -> Maybe a
Just (forall a b. a -> Either a b
Left Bool
newVal)}
                                                        where idx :: Word8
idx = IPin -> Word8
pinPortIndex IPin
o
                                                              newVal :: Bool
newVal | Word8
idx forall a. Ord a => a -> a -> Bool
<= Word8
6 = Word8
l forall a. Bits a => a -> Int -> Bool
`testBit` forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
idx
                                                                     | Bool
True     = Word8
h forall a. Bits a => a -> Int -> Bool
`testBit` forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8
idx forall a. Num a => a -> a -> a
- Word8
7)
                                                  let wakeUpQ :: [MVar ()]
wakeUpQ = BoardState -> [MVar ()]
digitalWakeUpQueue BoardState
bst
                                                      bst' :: BoardState
bst' = BoardState
bst{ pinStates :: Map IPin PinData
pinStates          = forall k a b. (k -> a -> b) -> Map k a -> Map k b
M.mapWithKey IPin -> PinData -> PinData
upd (BoardState -> Map IPin PinData
pinStates BoardState
bst)
                                                                , digitalWakeUpQueue :: [MVar ()]
digitalWakeUpQueue = []
                                                                }
                                                  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a. MVar a -> a -> IO ()
`putMVar` ()) [MVar ()]
wakeUpQ
                                                  forall (m :: * -> *) a. Monad m => a -> m a
return BoardState
bst'
                  Response
_                    -> do FilePath -> IO ()
dbg forall a b. (a -> b) -> a -> b
$ FilePath
"Received " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show Response
resp
                                             forall a. Chan a -> a -> IO ()
writeChan Chan Response
chan Response
resp
        MVar BoardState
bs <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ArduinoState -> MVar BoardState
boardState
        ThreadId
tid <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (MVar BoardState -> IO ()
listener MVar BoardState
bs)
        FilePath -> Arduino ()
debug forall a b. (a -> b) -> a -> b
$ FilePath
"Started listener thread: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show ThreadId
tid
        forall (m :: * -> *) a. Monad m => a -> m a
return ThreadId
tid

-- | Initialize our board, get capabilities, etc. Returns True if initialization
-- went OK, False if not.
initialize :: MVar ThreadId -> Arduino Bool
initialize :: MVar ThreadId -> Arduino Bool
initialize MVar ThreadId
ltid = do
     -- Step 0: Set up the listener thread
     ThreadId
tid <- Arduino ThreadId
setupListener
     forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> a -> IO ()
putMVar MVar ThreadId
ltid ThreadId
tid
     -- Step 1: Send a reset to get things going
     Request -> Arduino ()
send Request
SystemReset
     -- Step 2: Send query-firmware, and wait until we get a response
     -- To accommodate for the case when standard-Firmata may not be running,
     -- we will time out after 10 seconds of waiting, which should be plenty
     Maybe ()
mbTo <- forall {a}.
Request
-> Maybe Int
-> (Response -> Bool)
-> (Response -> Arduino a)
-> Arduino (Maybe a)
handshake Request
QueryFirmware (forall a. a -> Maybe a
Just (Int
5000000 :: Int))
                       (\case Firmware{} -> Bool
True
                              Response
_          -> Bool
False)
                       (\(Firmware Word8
v1 Word8
v2 FilePath
m) -> forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\ArduinoState
s -> ArduinoState
s{firmataID :: FilePath
firmataID = FilePath
"Firmware v" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show Word8
v1 forall a. [a] -> [a] -> [a]
++ FilePath
"." forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show Word8
v2 forall a. [a] -> [a] -> [a]
++ FilePath
"(" forall a. [a] -> [a] -> [a]
++ FilePath
m forall a. [a] -> [a] -> [a]
++ FilePath
")"}))
     case Maybe ()
mbTo of
       Maybe ()
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False  -- timed out
       Just () -> do -- Step 3: Send a capabilities request
                     Maybe ()
_ <- forall {a}.
Request
-> Maybe Int
-> (Response -> Bool)
-> (Response -> Arduino a)
-> Arduino (Maybe a)
handshake Request
CapabilityQuery forall a. Maybe a
Nothing
                                    (\case Capabilities{} -> Bool
True
                                           Response
_              -> Bool
False)
                                    (\(Capabilities BoardCapabilities
c) -> forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\ArduinoState
s -> ArduinoState
s{capabilities :: BoardCapabilities
capabilities = BoardCapabilities
c}))
                     -- Step 4: Send analog-mapping query
                     Maybe ()
_ <- forall {a}.
Request
-> Maybe Int
-> (Response -> Bool)
-> (Response -> Arduino a)
-> Arduino (Maybe a)
handshake Request
AnalogMappingQuery forall a. Maybe a
Nothing
                                    (\case AnalogMapping{} -> Bool
True
                                           Response
_               -> Bool
False)
                                    (\(AnalogMapping [Word8]
as) -> do BoardCapabilities Map IPin PinCapabilities
m <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ArduinoState -> BoardCapabilities
capabilities
                                                               -- need to put capabilities to both outer and inner state
                                                               let caps :: BoardCapabilities
caps = Map IPin PinCapabilities -> BoardCapabilities
BoardCapabilities (forall k a b. (k -> a -> b) -> Map k a -> Map k b
M.mapWithKey ([Word8] -> IPin -> PinCapabilities -> PinCapabilities
mapAnalog [Word8]
as) Map IPin PinCapabilities
m)
                                                               forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\ArduinoState
s -> ArduinoState
s{capabilities :: BoardCapabilities
capabilities = BoardCapabilities
caps})
                                                               MVar BoardState
bs <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ArduinoState -> MVar BoardState
boardState
                                                               forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar BoardState
bs forall a b. (a -> b) -> a -> b
$ \BoardState
bst -> forall (m :: * -> *) a. Monad m => a -> m a
return BoardState
bst{boardCapabilities :: BoardCapabilities
boardCapabilities = BoardCapabilities
caps})
                     -- We're done, print capabilities in debug mode
                     BoardCapabilities
caps <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ArduinoState -> BoardCapabilities
capabilities
                     FilePath -> IO ()
dbg <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ArduinoState -> FilePath -> IO ()
message
                     forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
dbg forall a b. (a -> b) -> a -> b
$ FilePath
"Handshake complete. Board capabilities:\n" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show BoardCapabilities
caps
                     forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
 where handshake :: Request
-> Maybe Int
-> (Response -> Bool)
-> (Response -> Arduino a)
-> Arduino (Maybe a)
handshake Request
msg Maybe Int
mbTOut Response -> Bool
isOK Response -> Arduino a
process = do
           FilePath -> IO ()
dbg <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ArduinoState -> FilePath -> IO ()
message
           Request -> Arduino ()
send Request
msg
           let wait :: Arduino (Maybe a)
wait = do Maybe Response
mbResp <- case Maybe Int
mbTOut of
                                     Maybe Int
Nothing -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Arduino Response
recv
                                     Just Int
n  -> Int -> Arduino (Maybe Response)
recvTimeOut Int
n
                         case Maybe Response
mbResp of
                           Maybe Response
Nothing   -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
                           Just Response
resp -> if Response -> Bool
isOK Response
resp
                                        then forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Response -> Arduino a
process Response
resp
                                        else do forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
dbg forall a b. (a -> b) -> a -> b
$ FilePath
"Skipping unexpected response: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show Response
resp
                                                Arduino (Maybe a)
wait
           Arduino (Maybe a)
wait
       mapAnalog :: [Word8] -> IPin -> PinCapabilities -> PinCapabilities
       mapAnalog :: [Word8] -> IPin -> PinCapabilities -> PinCapabilities
mapAnalog [Word8]
as IPin
p PinCapabilities
c
          | Int
i forall a. Ord a => a -> a -> Bool
< Int
rl Bool -> Bool -> Bool
&& Word8
m forall a. Eq a => a -> a -> Bool
/= Word8
0x7f
          = PinCapabilities
c{analogPinNumber :: Maybe Word8
analogPinNumber = forall a. a -> Maybe a
Just Word8
m}
          | Bool
True             -- out-of-bounds, or not analog; ignore
          = PinCapabilities
c
         where rl :: Int
rl = forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word8]
as
               i :: Int
i  = forall a b. (Integral a, Num b) => a -> b
fromIntegral (IPin -> Word8
pinNo IPin
p)
               m :: Word8
m  = [Word8]
as forall a. [a] -> Int -> a
!! Int
i