--------------------------------------------------------------------------------- |-- 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 #-}moduleSystem.Hardware.Arduino.CommwhereimportControl.Monad(when,forever)importControl.Concurrent(MVar,ThreadId,newChan,newMVar,newEmptyMVar,putMVar,writeChan,readChan,forkIO,modifyMVar_,tryTakeMVar,killThread)importControl.Exception(tryJust,AsyncException(UserInterrupt),handle,SomeException)importControl.Monad.State(runStateT,gets,liftIO,modify)importData.Bits(testBit,(.&.))importData.List(intercalate,isInfixOf)importData.Maybe(listToMaybe)importData.Word(Word8)importSystem.Timeout(timeout)importSystem.IO(stderr,hPutStrLn)importqualifiedData.ByteStringasB(unpack,length)importqualifiedData.MapasM(empty,mapWithKey,insert,assocs,lookup)importqualifiedData.SetasS(empty)importqualifiedSystem.Hardware.SerialportasS(withSerial,defaultSerialSettings,CommSpeed(CS57600),commSpeed,recv,send)importSystem.Hardware.Arduino.Data importSystem.Hardware.Arduino.Utils importSystem.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 =doFilePath -> 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
showFilePath
fp MVar ThreadId
lTid <-forall a. IO (MVar a)
newEmptyMVarletArduino StateT ArduinoState IO ()
controller =doBool
initOK <-MVar ThreadId -> Arduino Bool
initialize MVar ThreadId
lTid ifBool
initOK thenArduino ()
program elseforall a. HasCallStack => FilePath -> a
errorFilePath
"Communication time-out (5s) expired."forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle(\(SomeException
e ::SomeException)->doMVar ThreadId -> IO ()
cleanUp MVar ThreadId
lTid letselfErr :: Bool
selfErr =FilePath
"*** hArduino"forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf`forall a. Show a => a -> FilePath
showSomeException
e Handle -> FilePath -> IO ()
hPutStrLnHandle
stderrforall a b. (a -> b) -> a -> b
$ifBool
selfErr thenforall a. (a -> Bool) -> [a] -> [a]
dropWhile(forall a. Eq a => a -> a -> Bool
==Char
'\n')(forall a. Show a => a -> FilePath
showSomeException
e )elseFilePath
"*** hArduino:ERROR: "forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> FilePath
showSomeException
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.withSerialFilePath
fp SerialPortSettings
S.defaultSerialSettings{commSpeed :: CommSpeed
S.commSpeed=CommSpeed
S.CS57600}forall a b. (a -> b) -> a -> b
$\SerialPort
curPort ->doletinitBoardState :: 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)
newMVarBoardState
initBoardState Chan Response
dc <-forall a. IO (Chan a)
newChanletinitState :: 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)
tryJustAsyncException -> Maybe ()
catchCtrlC forall a b. (a -> b) -> a -> b
$forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateTStateT ArduinoState IO ()
controller ArduinoState
initState caseEither () ((), ArduinoState)
res ofLeft()->FilePath -> IO ()
putStrLnFilePath
"hArduino: Caught Ctrl-C, quitting.."Either () ((), ArduinoState)
_->forall (m :: * -> *) a. Monad m => a -> m a
return()MVar ThreadId -> IO ()
cleanUp MVar ThreadId
lTid wherecatchCtrlC :: AsyncException -> Maybe ()
catchCtrlC AsyncException
UserInterrupt=forall a. a -> Maybe a
Just()catchCtrlC AsyncException
_=forall a. Maybe a
NothingcleanUp :: MVar ThreadId -> IO ()
cleanUp MVar ThreadId
tid =doMaybe ThreadId
mbltid <-forall a. MVar a -> IO (Maybe a)
tryTakeMVarMVar ThreadId
tid forall b a. b -> (a -> b) -> Maybe a -> b
maybe(forall (f :: * -> *) a. Applicative f => a -> f a
pure())ThreadId -> IO ()
killThreadMaybe ThreadId
mbltid bailOutF :: MVar ThreadId -> FilePath -> [FilePath] -> IO b
bailOutF MVar ThreadId
tid FilePath
m [FilePath]
ms =doMVar ThreadId -> IO ()
cleanUp MVar ThreadId
tid forall a. HasCallStack => FilePath -> a
errorforall a b. (a -> b) -> a -> b
$FilePath
"\n*** hArduino:ERROR: "forall a. [a] -> [a] -> [a]
++forall a. [a] -> [[a]] -> [a]
intercalateFilePath
"\n*** "(FilePath
m forall a. a -> [a] -> [a]
:[FilePath]
ms )-- | Send down a request.send ::Request ->Arduino ()send :: Request -> Arduino ()
send Request
req =doFilePath -> Arduino ()
debug forall a b. (a -> b) -> a -> b
$FilePath
"Sending: "forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> FilePath
showRequest
req forall a. [a] -> [a] -> [a]
++FilePath
" <"forall a. [a] -> [a] -> [a]
++[FilePath] -> FilePath
unwords(forall a b. (a -> b) -> [a] -> [b]
mapWord8 -> FilePath
showByte (ByteString -> [Word8]
B.unpackByteString
p ))forall a. [a] -> [a] -> [a]
++FilePath
">"SerialPort
serial <-forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
getsArduinoState -> SerialPort
port Int
sent <-forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIOforall a b. (a -> b) -> a -> b
$SerialPort -> ByteString -> IO Int
S.sendSerialPort
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
showInt
lp forall a. [a] -> [a] -> [a]
++FilePath
"bytes, reported: "forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> FilePath
showInt
sent )wherep :: ByteString
p =Request -> ByteString
package Request
req lp :: Int
lp =ByteString -> Int
B.lengthByteString
p -- | Receive a sys-ex response. This is a blocking call.recv ::Arduino Response recv :: Arduino Response
recv =doChan Response
ch <-forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
getsArduinoState -> Chan Response
deviceChannel forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIOforall a b. (a -> b) -> a -> b
$forall a. Chan a -> IO a
readChanChan 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 receivedrecvTimeOut ::Int->Arduino (MaybeResponse )recvTimeOut :: Int -> Arduino (Maybe Response)
recvTimeOut Int
n =doChan Response
ch <-forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
getsArduinoState -> Chan Response
deviceChannel forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIOforall a b. (a -> b) -> a -> b
$forall a. Int -> IO a -> IO (Maybe a)
timeoutInt
n (forall a. Chan a -> IO a
readChanChan Response
ch )-- | Start a thread to listen to the board and populate the channel with incoming queries.setupListener ::Arduino ThreadIdsetupListener :: Arduino ThreadId
setupListener =doSerialPort
serial <-forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
getsArduinoState -> SerialPort
port FilePath -> IO ()
dbg <-forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
getsArduinoState -> FilePath -> IO ()
message Chan Response
chan <-forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
getsArduinoState -> Chan Response
deviceChannel letgetBytes :: Int -> IO [Word8]
getBytes Int
n =doletgo :: 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
returnforall a b. (a -> b) -> a -> b
$forall a. [a] -> [a]
reverse[ByteString]
sofar |Bool
True=doByteString
b <-SerialPort -> Int -> IO ByteString
S.recvSerialPort
serial Int
need caseByteString -> Int
B.lengthByteString
b ofInt
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
returnforall a b. (a -> b) -> a -> b
$forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMapByteString -> [Word8]
B.unpack[ByteString]
chunks collectSysEx :: [Word8] -> IO [Word8]
collectSysEx [Word8]
sofar =do[Word8
b ]<-Int -> IO [Word8]
getBytes Int
1ifWord8
b forall a. Eq a => a -> a -> Bool
==FirmataCmd -> Word8
firmataCmdVal FirmataCmd
END_SYSEX thenforall (m :: * -> *) a. Monad m => a -> m a
returnforall 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
1Response
resp <-caseWord8 -> Either Word8 FirmataCmd
getFirmataCmd Word8
cmd ofLeftWord8
unknown ->forall (m :: * -> *) a. Monad m => a -> m a
returnforall a b. (a -> b) -> a -> b
$Maybe FilePath -> [Word8] -> Response
Unimplemented (forall a. a -> Maybe a
Just(forall a. Show a => a -> FilePath
showWord8
unknown ))[]RightFirmataCmd
START_SYSEX ->[Word8] -> Response
unpackageSysEx forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap`[Word8] -> IO [Word8]
collectSysEx []RightFirmataCmd
nonSysEx ->(Int -> IO [Word8]) -> FirmataCmd -> IO Response
unpackageNonSysEx Int -> IO [Word8]
getBytes FirmataCmd
nonSysEx caseResponse
resp ofUnimplemented {}->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
showResponse
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 ->doletBoardCapabilities 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 =JustWord8
mp' })<-forall k a. Map k a -> [(k, a)]
M.assocsMap IPin PinCapabilities
caps ,IPin -> Word8
pinNo IPin
mp forall a. Eq a => a -> a -> Bool
==Word8
mp' ]caseMaybe IPin
mbP ofMaybe IPin
Nothing->forall (m :: * -> *) a. Monad m => a -> m a
returnBoardState
bst -- Mapping hasn't happened yetJustIPin
p ->doletv :: Int
v =(Int
128forall 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))::IntcasePinData -> 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 )ofJust(Just(RightInt
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 muchMaybe (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
showIPin
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
showInt
v forall a. [a] -> [a] -> [a]
++FilePath
")"forall (m :: * -> *) a. Monad m => a -> m a
returnBoardState
bst {pinStates :: Map IPin PinData
pinStates =forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insertIPin
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
RightInt
v )}(BoardState -> Map IPin PinData
pinStates BoardState
bst )}DigitalMessage Port
p Word8
l Word8
h ->doFilePath -> IO ()
dbg forall a b. (a -> b) -> a -> b
$FilePath
"Updating digital port "forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> FilePath
showPort
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 ->doletupd :: 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
LeftBool
newVal )}whereidx :: 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
fromIntegralWord8
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)letwakeUpQ :: [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.mapWithKeyIPin -> 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
returnBoardState
bst' Response
_->doFilePath -> IO ()
dbg forall a b. (a -> b) -> a -> b
$FilePath
"Received "forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> FilePath
showResponse
resp forall a. Chan a -> a -> IO ()
writeChanChan Response
chan Response
resp MVar BoardState
bs <-forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
getsArduinoState -> MVar BoardState
boardState ThreadId
tid <-forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIOforall a b. (a -> b) -> a -> b
$IO () -> IO ThreadId
forkIOforall 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
showThreadId
tid forall (m :: * -> *) a. Monad m => a -> m a
returnThreadId
tid -- | Initialize our board, get capabilities, etc. Returns True if initialization-- went OK, False if not.initialize ::MVarThreadId->Arduino Boolinitialize :: MVar ThreadId -> Arduino Bool
initialize MVar ThreadId
ltid =do-- Step 0: Set up the listener threadThreadId
tid <-Arduino ThreadId
setupListener forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIOforall a b. (a -> b) -> a -> b
$forall a. MVar a -> a -> IO ()
putMVarMVar ThreadId
ltid ThreadId
tid -- Step 1: Send a reset to get things goingRequest -> 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 plentyMaybe ()
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))(\caseFirmware {}->Bool
TrueResponse
_->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
showWord8
v1 forall a. [a] -> [a] -> [a]
++FilePath
"."forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> FilePath
showWord8
v2 forall a. [a] -> [a] -> [a]
++FilePath
"("forall a. [a] -> [a] -> [a]
++FilePath
m forall a. [a] -> [a] -> [a]
++FilePath
")"}))caseMaybe ()
mbTo ofMaybe ()
Nothing->forall (m :: * -> *) a. Monad m => a -> m a
returnBool
False-- timed outJust()->do-- Step 3: Send a capabilities requestMaybe ()
_<-forall {a}.
Request
-> Maybe Int
-> (Response -> Bool)
-> (Response -> Arduino a)
-> Arduino (Maybe a)
handshake Request
CapabilityQuery forall a. Maybe a
Nothing(\caseCapabilities {}->Bool
TrueResponse
_->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 queryMaybe ()
_<-forall {a}.
Request
-> Maybe Int
-> (Response -> Bool)
-> (Response -> Arduino a)
-> Arduino (Maybe a)
handshake Request
AnalogMappingQuery forall a. Maybe a
Nothing(\caseAnalogMapping {}->Bool
TrueResponse
_->Bool
False)(\(AnalogMapping [Word8]
as )->doBoardCapabilities Map IPin PinCapabilities
m <-forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
getsArduinoState -> BoardCapabilities
capabilities -- need to put capabilities to both outer and inner stateletcaps :: 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
getsArduinoState -> MVar BoardState
boardState forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIOforall 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
returnBoardState
bst {boardCapabilities :: BoardCapabilities
boardCapabilities =BoardCapabilities
caps })-- We're done, print capabilities in debug modeBoardCapabilities
caps <-forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
getsArduinoState -> BoardCapabilities
capabilities FilePath -> IO ()
dbg <-forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
getsArduinoState -> FilePath -> IO ()
message forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIOforall 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
showBoardCapabilities
caps forall (m :: * -> *) a. Monad m => a -> m a
returnBool
Truewherehandshake :: Request
-> Maybe Int
-> (Response -> Bool)
-> (Response -> Arduino a)
-> Arduino (Maybe a)
handshake Request
msg Maybe Int
mbTOut Response -> Bool
isOK Response -> Arduino a
process =doFilePath -> IO ()
dbg <-forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
getsArduinoState -> FilePath -> IO ()
message Request -> Arduino ()
send Request
msg letwait :: Arduino (Maybe a)
wait =doMaybe Response
mbResp <-caseMaybe Int
mbTOut ofMaybe Int
Nothing->forall a. a -> Maybe a
Justforall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap`Arduino Response
recv JustInt
n ->Int -> Arduino (Maybe Response)
recvTimeOut Int
n caseMaybe Response
mbResp ofMaybe Response
Nothing->forall (m :: * -> *) a. Monad m => a -> m a
returnforall a. Maybe a
NothingJustResponse
resp ->ifResponse -> Bool
isOK Response
resp thenforall a. a -> Maybe a
Justforall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap`Response -> Arduino a
process Response
resp elsedoforall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIOforall 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
showResponse
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
JustWord8
m }|Bool
True-- out-of-bounds, or not analog; ignore=PinCapabilities
c whererl :: 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