-------------------------------------------------------------------------------
-- |
-- 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 (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Accessing arduino located at: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
forall a. Show a => a -> FilePath
show FilePath
fp
           MVar ThreadId
lTid <- IO (MVar ThreadId)
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 FilePath -> Arduino ()
forall a. HasCallStack => FilePath -> a
error FilePath
"Communication time-out (5s) expired."
           (SomeException -> IO ()) -> IO () -> IO ()
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" FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` SomeException -> FilePath
forall a. Show a => a -> FilePath
show SomeException
e
                                             Handle -> FilePath -> IO ()
hPutStrLn Handle
stderr (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ if Bool
selfErr
                                                                then (Char -> Bool) -> FilePath -> FilePath
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n') (SomeException -> FilePath
forall a. Show a => a -> FilePath
show SomeException
e)
                                                                else FilePath
"*** hArduino:ERROR: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ SomeException -> FilePath
forall a. Show a => a -> FilePath
show SomeException
e
                                                                     FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ (FilePath -> FilePath) -> [FilePath] -> FilePath
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (FilePath
"\n*** " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++) [ FilePath
"Make sure your Arduino is connected to " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
fp
                                                                                                , FilePath
"And StandardFirmata is running on it!"
                                                                                                ]) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
             FilePath -> SerialPortSettings -> (SerialPort -> IO ()) -> IO ()
forall a.
FilePath -> SerialPortSettings -> (SerialPort -> IO a) -> IO a
S.withSerial FilePath
fp SerialPortSettings
S.defaultSerialSettings{S.commSpeed = S.CS57600} ((SerialPort -> IO ()) -> IO ()) -> (SerialPort -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \SerialPort
curPort -> do
                let initBoardState :: BoardState
initBoardState = BoardState {
                                         boardCapabilities :: BoardCapabilities
boardCapabilities    = Map IPin PinCapabilities -> BoardCapabilities
BoardCapabilities Map IPin PinCapabilities
forall k a. Map k a
M.empty
                                       , analogReportingPins :: Set IPin
analogReportingPins  = Set IPin
forall a. Set a
S.empty
                                       , digitalReportingPins :: Set IPin
digitalReportingPins = Set IPin
forall a. Set a
S.empty
                                       , pinStates :: Map IPin PinData
pinStates            = Map IPin PinData
forall k a. Map k a
M.empty
                                       , digitalWakeUpQueue :: [MVar ()]
digitalWakeUpQueue   = []
                                       , lcds :: Map LCD LCDData
lcds                 = Map LCD LCDData
forall k a. Map k a
M.empty
                                     }
                MVar BoardState
bs <- BoardState -> IO (MVar BoardState)
forall a. a -> IO (MVar a)
newMVar BoardState
initBoardState
                Chan Response
dc <- IO (Chan Response)
forall a. IO (Chan a)
newChan
                let initState :: ArduinoState
initState = ArduinoState {
                                   message :: FilePath -> IO ()
message       = FilePath -> IO ()
debugger
                                 , bailOut :: FilePath -> [FilePath] -> IO ()
bailOut       = MVar ThreadId -> FilePath -> [FilePath] -> IO ()
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 Map IPin PinCapabilities
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 <- (AsyncException -> Maybe ())
-> IO ((), ArduinoState) -> IO (Either () ((), ArduinoState))
forall e b a.
Exception e =>
(e -> Maybe b) -> IO a -> IO (Either b a)
tryJust AsyncException -> Maybe ()
catchCtrlC (IO ((), ArduinoState) -> IO (Either () ((), ArduinoState)))
-> IO ((), ArduinoState) -> IO (Either () ((), ArduinoState))
forall a b. (a -> b) -> a -> b
$ StateT ArduinoState IO () -> ArduinoState -> IO ((), ArduinoState)
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)
_       -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                MVar ThreadId -> IO ()
cleanUp MVar ThreadId
lTid
 where catchCtrlC :: AsyncException -> Maybe ()
catchCtrlC AsyncException
UserInterrupt = () -> Maybe ()
forall a. a -> Maybe a
Just ()
       catchCtrlC AsyncException
_             = Maybe ()
forall a. Maybe a
Nothing

       cleanUp :: MVar ThreadId -> IO ()
cleanUp MVar ThreadId
tid = do Maybe ThreadId
mbltid <- MVar ThreadId -> IO (Maybe ThreadId)
forall a. MVar a -> IO (Maybe a)
tryTakeMVar MVar ThreadId
tid
                        IO () -> (ThreadId -> IO ()) -> Maybe ThreadId -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall a. a -> IO a
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
                              FilePath -> IO b
forall a. HasCallStack => FilePath -> a
error (FilePath -> IO b) -> FilePath -> IO b
forall a b. (a -> b) -> a -> b
$ FilePath
"\n*** hArduino:ERROR: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
"\n*** " (FilePath
mFilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
:[FilePath]
ms)

-- | Send down a request.
send :: Request -> Arduino ()
send :: Request -> Arduino ()
send Request
req = do FilePath -> Arduino ()
debug (FilePath -> Arduino ()) -> FilePath -> Arduino ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Sending: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Request -> FilePath
forall a. Show a => a -> FilePath
show Request
req FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" <" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ [FilePath] -> FilePath
unwords ((Word8 -> FilePath) -> [Word8] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map Word8 -> FilePath
showByte (ByteString -> [Word8]
B.unpack ByteString
p)) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
">"
              SerialPort
serial <- (ArduinoState -> SerialPort) -> Arduino SerialPort
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ArduinoState -> SerialPort
port
              Int
sent <- IO Int -> Arduino Int
forall a. IO a -> Arduino a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> Arduino Int) -> IO Int -> Arduino Int
forall a b. (a -> b) -> a -> b
$ SerialPort -> ByteString -> IO Int
S.send SerialPort
serial ByteString
p
              Bool -> Arduino () -> Arduino ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
sent Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
lp)
                   (FilePath -> Arduino ()
debug (FilePath -> Arduino ()) -> FilePath -> Arduino ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Send failed. Tried: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
lp FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"bytes, reported: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
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 <- (ArduinoState -> Chan Response) -> Arduino (Chan Response)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ArduinoState -> Chan Response
deviceChannel
          IO Response -> Arduino Response
forall a. IO a -> Arduino a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Response -> Arduino Response)
-> IO Response -> Arduino Response
forall a b. (a -> b) -> a -> b
$ Chan Response -> IO Response
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 <- (ArduinoState -> Chan Response) -> Arduino (Chan Response)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ArduinoState -> Chan Response
deviceChannel
                   IO (Maybe Response) -> Arduino (Maybe Response)
forall a. IO a -> Arduino a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Response) -> Arduino (Maybe Response))
-> IO (Maybe Response) -> Arduino (Maybe Response)
forall a b. (a -> b) -> a -> b
$ Int -> IO Response -> IO (Maybe Response)
forall a. Int -> IO a -> IO (Maybe a)
timeout Int
n (Chan Response -> IO Response
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 <- (ArduinoState -> SerialPort) -> Arduino SerialPort
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ArduinoState -> SerialPort
port
        FilePath -> IO ()
dbg    <- (ArduinoState -> FilePath -> IO ()) -> Arduino (FilePath -> IO ())
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ArduinoState -> FilePath -> IO ()
message
        Chan Response
chan   <- (ArduinoState -> Chan Response) -> Arduino (Chan Response)
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0  = [ByteString] -> IO [ByteString]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([ByteString] -> IO [ByteString])
-> [ByteString] -> IO [ByteString]
forall a b. (a -> b) -> a -> b
$ [ByteString] -> [ByteString]
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
l) (ByteString
b ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: [ByteString]
sofar)
                            [ByteString]
chunks <- Int -> [ByteString] -> IO [ByteString]
go Int
n []
                            [Word8] -> IO [Word8]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Word8] -> IO [Word8]) -> [Word8] -> IO [Word8]
forall a b. (a -> b) -> a -> b
$ (ByteString -> [Word8]) -> [ByteString] -> [Word8]
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 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== FirmataCmd -> Word8
firmataCmdVal FirmataCmd
END_SYSEX
                                       then [Word8] -> IO [Word8]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Word8] -> IO [Word8]) -> [Word8] -> IO [Word8]
forall a b. (a -> b) -> a -> b
$ [Word8] -> [Word8]
forall a. [a] -> [a]
reverse [Word8]
sofar
                                       else [Word8] -> IO [Word8]
collectSysEx (Word8
b Word8 -> [Word8] -> [Word8]
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     -> Response -> IO Response
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Response -> IO Response) -> Response -> IO Response
forall a b. (a -> b) -> a -> b
$ Maybe FilePath -> [Word8] -> Response
Unimplemented (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (Word8 -> FilePath
forall a. Show a => a -> FilePath
show Word8
unknown)) []
                           Right FirmataCmd
START_SYSEX -> [Word8] -> Response
unpackageSysEx ([Word8] -> Response) -> IO [Word8] -> IO Response
forall a b. (a -> b) -> IO a -> IO b
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 (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Ignoring the received response: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Response -> FilePath
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 -> MVar BoardState -> (BoardState -> IO BoardState) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar BoardState
bs ((BoardState -> IO BoardState) -> IO ())
-> (BoardState -> IO BoardState) -> IO ()
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 = [IPin] -> Maybe IPin
forall a. [a] -> Maybe a
listToMaybe [IPin
mappedPin | (IPin
mappedPin, PinCapabilities{analogPinNumber :: PinCapabilities -> Maybe Word8
analogPinNumber = Just Word8
mp'}) <- Map IPin PinCapabilities -> [(IPin, PinCapabilities)]
forall k a. Map k a -> [(k, a)]
M.assocs Map IPin PinCapabilities
caps, IPin -> Word8
pinNo IPin
mp Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
mp']
                                              case Maybe IPin
mbP of
                                                Maybe IPin
Nothing -> BoardState -> IO BoardState
forall a. a -> IO a
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8
h Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0x07) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8
l Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0x7f)) :: Int
                                                   case PinData -> Maybe (Either Bool Int)
pinValue (PinData -> Maybe (Either Bool Int))
-> Maybe PinData -> Maybe (Maybe (Either Bool Int))
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (IPin
p IPin -> Map IPin PinData -> Maybe PinData
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'))
                                                       | Int -> Int
forall a. Num a => a -> a
abs (Int
v Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
v') Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
10  -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return () -- be quiet, otherwise prints too much
                                                     Maybe (Maybe (Either Bool Int))
_                      -> FilePath -> IO ()
dbg (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Updating analog pin " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ IPin -> FilePath
forall a. Show a => a -> FilePath
show IPin
p FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" values with " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ [Word8] -> FilePath
showByteList [Word8
l,Word8
h] FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" (" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
v FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
")"
                                                   BoardState -> IO BoardState
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return BoardState
bst{ pinStates = M.insert p PinData{pinMode = ANALOG, pinValue = Just (Right v)} (pinStates bst) }
                  DigitalMessage Port
p Word8
l Word8
h -> do FilePath -> IO ()
dbg (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Updating digital port " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Port -> FilePath
forall a. Show a => a -> FilePath
show Port
p FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" values with " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ [Word8] -> FilePath
showByteList [Word8
l,Word8
h]
                                             MVar BoardState -> (BoardState -> IO BoardState) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar BoardState
bs ((BoardState -> IO BoardState) -> IO ())
-> (BoardState -> IO BoardState) -> IO ()
forall a b. (a -> b) -> a -> b
$ \BoardState
bst -> do
                                                  let upd :: IPin -> PinData -> PinData
upd IPin
o PinData
od | Port
p Port -> Port -> Bool
forall a. Eq a => a -> a -> Bool
/= IPin -> Port
pinPort IPin
o      = PinData
od   -- different port, no change
                                                               | PinData -> PinMode
pinMode PinData
od PinMode -> PinMode -> Bool
forall a. Eq a => a -> a -> Bool
/= PinMode
INPUT = PinData
od   -- not an input pin, ignore
                                                               | Bool
True                = PinData
od{pinValue = Just (Left newVal)}
                                                        where idx :: Word8
idx = IPin -> Word8
pinPortIndex IPin
o
                                                              newVal :: Bool
newVal | Word8
idx Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
6 = Word8
l Word8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
`testBit` Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
idx
                                                                     | Bool
True     = Word8
h Word8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
`testBit` Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8
idx Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
- Word8
7)
                                                  let wakeUpQ :: [MVar ()]
wakeUpQ = BoardState -> [MVar ()]
digitalWakeUpQueue BoardState
bst
                                                      bst' :: BoardState
bst' = BoardState
bst{ pinStates          = M.mapWithKey upd (pinStates bst)
                                                                , digitalWakeUpQueue = []
                                                                }
                                                  (MVar () -> IO ()) -> [MVar ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
`putMVar` ()) [MVar ()]
wakeUpQ
                                                  BoardState -> IO BoardState
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return BoardState
bst'
                  Response
_                    -> do FilePath -> IO ()
dbg (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Received " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Response -> FilePath
forall a. Show a => a -> FilePath
show Response
resp
                                             Chan Response -> Response -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan Response
chan Response
resp
        MVar BoardState
bs <- (ArduinoState -> MVar BoardState) -> Arduino (MVar BoardState)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ArduinoState -> MVar BoardState
boardState
        ThreadId
tid <- IO ThreadId -> Arduino ThreadId
forall a. IO a -> Arduino a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ThreadId -> Arduino ThreadId)
-> IO ThreadId -> Arduino ThreadId
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (MVar BoardState -> IO ()
listener MVar BoardState
bs)
        FilePath -> Arduino ()
debug (FilePath -> Arduino ()) -> FilePath -> Arduino ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Started listener thread: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ThreadId -> FilePath
forall a. Show a => a -> FilePath
show ThreadId
tid
        ThreadId -> Arduino ThreadId
forall a. a -> Arduino a
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
     IO () -> Arduino ()
forall a. IO a -> Arduino a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Arduino ()) -> IO () -> Arduino ()
forall a b. (a -> b) -> a -> b
$ MVar ThreadId -> ThreadId -> IO ()
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 <- Request
-> Maybe Int
-> (Response -> Bool)
-> (Response -> Arduino ())
-> Arduino (Maybe ())
forall {a}.
Request
-> Maybe Int
-> (Response -> Bool)
-> (Response -> Arduino a)
-> Arduino (Maybe a)
handshake Request
QueryFirmware (Int -> Maybe Int
forall a. a -> Maybe a
Just (Int
5000000 :: Int))
                       (\case Firmware{} -> Bool
True
                              Response
_          -> Bool
False)
                       (\(Firmware Word8
v1 Word8
v2 FilePath
m) -> (ArduinoState -> ArduinoState) -> Arduino ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\ArduinoState
s -> ArduinoState
s{firmataID = "Firmware v" ++ show v1 ++ "." ++ show v2 ++ "(" ++ m ++ ")"}))
     case Maybe ()
mbTo of
       Maybe ()
Nothing -> Bool -> Arduino Bool
forall a. a -> Arduino a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False  -- timed out
       Just () -> do -- Step 3: Send a capabilities request
                     Maybe ()
_ <- Request
-> Maybe Int
-> (Response -> Bool)
-> (Response -> Arduino ())
-> Arduino (Maybe ())
forall {a}.
Request
-> Maybe Int
-> (Response -> Bool)
-> (Response -> Arduino a)
-> Arduino (Maybe a)
handshake Request
CapabilityQuery Maybe Int
forall a. Maybe a
Nothing
                                    (\case Capabilities{} -> Bool
True
                                           Response
_              -> Bool
False)
                                    (\(Capabilities BoardCapabilities
c) -> (ArduinoState -> ArduinoState) -> Arduino ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\ArduinoState
s -> ArduinoState
s{capabilities = c}))
                     -- Step 4: Send analog-mapping query
                     Maybe ()
_ <- Request
-> Maybe Int
-> (Response -> Bool)
-> (Response -> Arduino ())
-> Arduino (Maybe ())
forall {a}.
Request
-> Maybe Int
-> (Response -> Bool)
-> (Response -> Arduino a)
-> Arduino (Maybe a)
handshake Request
AnalogMappingQuery Maybe Int
forall a. Maybe a
Nothing
                                    (\case AnalogMapping{} -> Bool
True
                                           Response
_               -> Bool
False)
                                    (\(AnalogMapping [Word8]
as) -> do BoardCapabilities Map IPin PinCapabilities
m <- (ArduinoState -> BoardCapabilities) -> Arduino BoardCapabilities
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 ((IPin -> PinCapabilities -> PinCapabilities)
-> Map IPin PinCapabilities -> Map IPin PinCapabilities
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)
                                                               (ArduinoState -> ArduinoState) -> Arduino ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\ArduinoState
s -> ArduinoState
s{capabilities = caps})
                                                               MVar BoardState
bs <- (ArduinoState -> MVar BoardState) -> Arduino (MVar BoardState)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ArduinoState -> MVar BoardState
boardState
                                                               IO () -> Arduino ()
forall a. IO a -> Arduino a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Arduino ()) -> IO () -> Arduino ()
forall a b. (a -> b) -> a -> b
$ MVar BoardState -> (BoardState -> IO BoardState) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar BoardState
bs ((BoardState -> IO BoardState) -> IO ())
-> (BoardState -> IO BoardState) -> IO ()
forall a b. (a -> b) -> a -> b
$ \BoardState
bst -> BoardState -> IO BoardState
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return BoardState
bst{boardCapabilities = caps})
                     -- We're done, print capabilities in debug mode
                     BoardCapabilities
caps <- (ArduinoState -> BoardCapabilities) -> Arduino BoardCapabilities
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ArduinoState -> BoardCapabilities
capabilities
                     FilePath -> IO ()
dbg <- (ArduinoState -> FilePath -> IO ()) -> Arduino (FilePath -> IO ())
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ArduinoState -> FilePath -> IO ()
message
                     IO () -> Arduino ()
forall a. IO a -> Arduino a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Arduino ()) -> IO () -> Arduino ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
dbg (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Handshake complete. Board capabilities:\n" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ BoardCapabilities -> FilePath
forall a. Show a => a -> FilePath
show BoardCapabilities
caps
                     Bool -> Arduino Bool
forall a. a -> Arduino a
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 <- (ArduinoState -> FilePath -> IO ()) -> Arduino (FilePath -> IO ())
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 -> Response -> Maybe Response
forall a. a -> Maybe a
Just (Response -> Maybe Response)
-> Arduino Response -> Arduino (Maybe Response)
forall a b. (a -> b) -> Arduino a -> Arduino b
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   -> Maybe a -> Arduino (Maybe a)
forall a. a -> Arduino a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
                           Just Response
resp -> if Response -> Bool
isOK Response
resp
                                        then a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> Arduino a -> Arduino (Maybe a)
forall a b. (a -> b) -> Arduino a -> Arduino b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Response -> Arduino a
process Response
resp
                                        else do IO () -> Arduino ()
forall a. IO a -> Arduino a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Arduino ()) -> IO () -> Arduino ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
dbg (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Skipping unexpected response: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Response -> FilePath
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
rl Bool -> Bool -> Bool
&& Word8
m Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
0x7f
          = PinCapabilities
c{analogPinNumber = Just m}
          | Bool
True             -- out-of-bounds, or not analog; ignore
          = PinCapabilities
c
         where rl :: Int
rl = [Word8] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word8]
as
               i :: Int
i  = Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (IPin -> Word8
pinNo IPin
p)
               m :: Word8
m  = [Word8]
as [Word8] -> Int -> Word8
forall a. HasCallStack => [a] -> Int -> a
!! Int
i