{-# 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
withArduino :: Bool
-> FilePath
-> Arduino ()
-> 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 :: 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
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
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)
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
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
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 ()
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
| PinData -> PinMode
pinMode PinData
od forall a. Eq a => a -> a -> Bool
/= PinMode
INPUT = PinData
od
| 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 :: MVar ThreadId -> Arduino Bool
initialize :: MVar ThreadId -> Arduino Bool
initialize MVar ThreadId
ltid = do
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
Request -> Arduino ()
send Request
SystemReset
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
Just () -> do
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}))
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
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})
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
= 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