hArduino 0.1 → 0.2
raw patch · 11 files changed
+654/−231 lines, 11 filesdep +containersdep +unixPVP ok
version bump matches the API change (PVP)
Dependencies added: containers, unix
API changes (from Hackage documentation)
+ System.Hardware.Arduino: I2C :: PinMode
+ System.Hardware.Arduino: SHIFT :: PinMode
+ System.Hardware.Arduino: waitFor :: Pin -> Arduino Bool
+ System.Hardware.Arduino.Examples.Switch: switch :: IO ()
- System.Hardware.Arduino: digitalRead :: Pin -> Arduino (PinMode, Bool)
+ System.Hardware.Arduino: digitalRead :: Pin -> Arduino Bool
- System.Hardware.Arduino: pin :: Int -> Pin
+ System.Hardware.Arduino: pin :: Word8 -> Pin
Files
- RELEASENOTES +8/−1
- System/Hardware/Arduino.hs +1/−2
- System/Hardware/Arduino/Comm.hs +138/−43
- System/Hardware/Arduino/Data.hs +323/−36
- System/Hardware/Arduino/Examples/Blink.hs +3/−0
- System/Hardware/Arduino/Examples/Switch.hs +49/−0
- System/Hardware/Arduino/Firmata/Basics.hs +56/−28
- System/Hardware/Arduino/Parts.hs +0/−45
- System/Hardware/Arduino/Protocol.hs +52/−71
- System/Hardware/Arduino/Utils.hs +17/−0
- hArduino.cabal +7/−5
RELEASENOTES view
@@ -1,7 +1,14 @@ Hackage: http://hackage.haskell.org/package/hArduino GitHub: http://leventerkok.github.com/hArduino -Latest Hackage released version: 0.1+Latest Hackage released version: 0.2++======================================================================+Version 0.2, 2013-01-28++ - Rewrite the communication engine+ - Digital input/output implementation+ - Add switch example ====================================================================== Version 0.1, 2013-01-14
System/Hardware/Arduino.hs view
@@ -29,7 +29,7 @@ -- ** Reading and Writing digital values , digitalRead, digitalWrite -- ** Misc utilities- , delay+ , waitFor, delay -- * Hardware components on the board -- ** Pins , pin, PinMode(..)@@ -39,4 +39,3 @@ import System.Hardware.Arduino.Data import System.Hardware.Arduino.Comm import System.Hardware.Arduino.Firmata-import System.Hardware.Arduino.Parts
System/Hardware/Arduino/Comm.hs view
@@ -12,15 +12,21 @@ {-# LANGUAGE NamedFieldPuns #-} module System.Hardware.Arduino.Comm where -import Control.Monad.State (modify, runStateT, when)+import Control.Monad (when, forever)+import Control.Concurrent (myThreadId, throwTo, newChan, newMVar, putMVar, writeChan, readChan, forkIO, modifyMVar_)+import Control.Exception (tryJust, AsyncException(UserInterrupt))+import Control.Monad.State (runStateT, gets, liftIO, modify)+import Data.Bits (testBit)+import System.Posix.Signals (installHandler, keyboardSignal, Handler(Catch)) -import qualified Data.ByteString as B (pack, unpack, concat, length)+import qualified Data.ByteString as B (unpack, length)+import qualified Data.Map as M (empty, mapWithKey)+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-import System.Hardware.Arduino.Firmata -- | Run the Haskell program to control the board: --@@ -39,46 +45,135 @@ -> Arduino () -- ^ The Haskell controller program to run -> IO () withArduino verbose fp program =- do debugger <- mkDebugPrinter verbose+ do tid <- myThreadId+ _ <- installHandler keyboardSignal (Catch (throwTo tid UserInterrupt)) Nothing+ debugger <- mkDebugPrinter verbose debugger $ "Accessing arduino located at: " ++ show fp- let Arduino controller = do (v1, v2, m) <- queryFirmware- modify (\b -> b{firmataID = "Firmware v" ++ show v1 ++ "." ++ show v2 ++ "(" ++ m ++ ")"})+ let Arduino controller = do initialize program S.withSerial fp S.defaultSerialSettings{S.commSpeed = S.CS57600} $ \port -> do- _ <- runStateT controller (mkState debugger port)- return ()- where mkState debugger port = ArduinoState debugger port "ID: Uninitialized" (Just (ArduinoChannel recvChan recvNChan sendChan))- where extract b = do let resp = unpackage b- debugger $ "Received: " ++ show resp- return resp- recvChan = do debugger "Waiting for a Sysex response.."- let skip = do b <- S.recv port 1- case B.unpack b of- [] -> skip- [0xF0] -> return ()- bs -> do debugger $ "Skipping bytes <" ++ unwords (map showByte bs) ++ ">"- skip- collect sofar = do b <- S.recv port 1- let rmsg = b : sofar- if b == B.pack [0xF7] -- end message- then return $ reverse rmsg- else collect rmsg- skip- chunks <- collect [B.pack [0xF0]]- extract $ B.concat chunks- recvNChan n = do debugger $ "Waiting for a non-Sysex response of " ++ show n ++ " bytes"- let go need sofar- | need <= 0 = return sofar- | True = do b <- S.recv port need- case B.length b of- 0 -> go need sofar- l -> do when (need < l) $ debugger $ "Received partial response: <" ++ unwords (map showByte (B.unpack b)) ++ ">"- go (need - l) (b : sofar)- chunks <- go n []- extract $ B.concat $ reverse chunks- sendChan msg = do let p = package msg- lp = B.length p- debugger $ "Sending: " ++ show msg ++ " <" ++ unwords (map showByte (B.unpack p)) ++ ">"- sent <- S.send port p- when (sent /= lp)- (debugger $ "Send failed. Tried: " ++ show lp ++ "bytes, reported: " ++ show sent)+ let initBoardState = BoardState {+ analogReportingPins = S.empty+ , digitalReportingPins = S.empty+ , pinStates = M.empty+ , digitalWakeUpQueue = []+ }+ bs <- newMVar initBoardState+ dc <- newChan+ let initState = ArduinoState {+ message = debugger+ , port = port+ , firmataID = "Unknown"+ , capabilities = BoardCapabilities M.empty+ , boardState = bs+ , deviceChannel = dc+ }+ res <- tryJust catchCtrlC $ runStateT controller initState+ case res of+ Left () -> putStrLn "hArduino: Caught Ctrl-C, quitting.."+ _ -> return ()+ where catchCtrlC UserInterrupt = Just ()+ catchCtrlC _ = Nothing++-- | Send down a request.+send :: Request -> Arduino ()+send req = do debug $ "Sending: " ++ show req ++ " <" ++ unwords (map showByte (B.unpack p)) ++ ">"+ serial <- gets port+ sent <- liftIO $ S.send serial p+ when (sent /= lp)+ (debug $ "Send failed. Tried: " ++ show lp ++ "bytes, reported: " ++ show sent)+ where p = package req+ lp = B.length p++-- | Receive a sys-ex response. This is a blocking call.+recv :: Arduino Response+recv = do ch <- gets deviceChannel+ liftIO $ readChan ch++-- | Start a thread to listen to the board and populate the channel with incoming queries.+-- NB. This function is run in a thread; so be careful not to throw error or die otherwise+-- in here.+setupListener :: Arduino ()+setupListener = do+ serial <- gets port+ dbg <- gets message+ chan <- gets deviceChannel+ let getBytes n = do let go need sofar+ | need <= 0 = return $ reverse sofar+ | True = do b <- S.recv serial need+ case B.length b of+ 0 -> go need sofar+ l -> go (need - l) (b : sofar)+ chunks <- go n []+ return $ concatMap B.unpack chunks+ collectSysEx sofar = do [b] <- getBytes 1+ if b == firmataCmdVal END_SYSEX+ then return $ reverse sofar+ else collectSysEx (b : sofar)+ listener bs = do+ [cmd] <- getBytes 1+ resp <- case getFirmataCmd cmd of+ Left unknown -> return $ Unimplemented (Just (show unknown)) []+ Right START_SYSEX -> unpackageSysEx `fmap` collectSysEx []+ Right nonSysEx -> unpackageNonSysEx getBytes nonSysEx+ case resp of+ Unimplemented{} -> dbg $ "Ignoring the received response: " ++ show resp+ DigitalMessage p l h -> do dbg $ "Updating port " ++ show p ++ " values with " ++ showByteList [l,h]+ modifyMVar_ bs $ \bst -> do+ let upd o od | p /= pinPort o = od -- different port, no change+ | pinMode od `notElem` [INPUT] = od -- not an input pin, ignore+ | True = od{pinValue = Just (Left newVal)}+ where idx = pinPortIndex o+ newVal | idx <= 6 = l `testBit` fromIntegral idx+ | True = h `testBit` fromIntegral (idx - 7)+ let wakeUpQ = digitalWakeUpQueue bst+ bst' = bst{ pinStates = M.mapWithKey upd (pinStates bst)+ , digitalWakeUpQueue = []+ }+ mapM_ (`putMVar` ()) wakeUpQ+ return bst'+ _ -> do dbg $ "Received " ++ show resp+ writeChan chan resp+ bs <- gets boardState+ tid <- liftIO $ forkIO $ forever (listener bs)+ debug $ "Started listener thread: " ++ show tid++-- | Initialize our board, get capabilities, etc+initialize :: Arduino ()+initialize = do+ -- Step 1: Set up the listener thread+ setupListener+ -- Step 2: Send query-firmware, and wait until we get a response+ handshake QueryFirmware+ (\r -> case r of {Firmware{} -> True; _ -> False})+ (\(Firmware v1 v2 m) -> modify (\s -> s{firmataID = "Firmware v" ++ show v1 ++ "." ++ show v2 ++ "(" ++ m ++ ")"}))+ -- Step 3: Send a capabilities request+ handshake CapabilityQuery+ (\r -> case r of {Capabilities{} -> True; _ -> False})+ (\(Capabilities c) -> modify (\s -> s{capabilities = c}))+ -- Step 4: Send analog-mapping query+ handshake AnalogMappingQuery+ (\r -> case r of {AnalogMapping{} -> True; _ -> False})+ (\(AnalogMapping bs) -> do BoardCapabilities m <- gets capabilities+ modify (\s -> s{capabilities = BoardCapabilities (M.mapWithKey (mapAnalog bs) m)}))+ -- We're done, print capabilities in debug mode+ cs <- gets capabilities+ dbg <- gets message+ liftIO $ dbg $ "Handshake complete. Board capabilities:\n" ++ show cs+ where handshake msg isOK process = do+ dbg <- gets message+ send msg+ let wait = do resp <- recv+ if isOK resp+ then process resp+ else do liftIO $ dbg $ "Skpping unexpected response: " ++ show resp+ wait+ wait+ mapAnalog bs p c+ | i < rl && m /= 0x7f+ = (Just m, snd c)+ | True -- out-of-bounds, or not analog; ignore+ = c+ where rl = length bs+ i = fromIntegral (pinNo p)+ m = bs !! i
System/Hardware/Arduino/Data.hs view
@@ -14,52 +14,339 @@ {-# LANGUAGE NamedFieldPuns #-} module System.Hardware.Arduino.Data where -import Control.Monad.State (StateT, MonadIO, MonadState, gets, liftIO)-import Data.Maybe (fromMaybe)-import System.Hardware.Serialport (SerialPort)+import Control.Applicative (Applicative)+import Control.Concurrent (Chan, MVar, modifyMVar, modifyMVar_, readMVar)+import Control.Monad.State (StateT, MonadIO, MonadState, gets, liftIO)+import Data.Bits ((.&.), (.|.), setBit)+import Data.List (intercalate)+import Data.Maybe (fromMaybe)+import Data.Word (Word8)+import System.Hardware.Serialport (SerialPort) -import System.Hardware.Arduino.Protocol+import qualified Data.Map as M+import qualified Data.Set as S --- | Basic communication channel with the board.-data ArduinoChannel = ArduinoChannel {- recvChan :: IO Response -- ^ Receive a sys-ex response.- , recvNChan :: Int -> IO Response -- ^ Receive a non-sys-ex response that has /n/ bytes in it- , sendChan :: Request -> IO () -- ^ Send a request down to Arduino- }+import System.Hardware.Arduino.Utils --- | State of the board and other machinery.+-- | A port (containing 8 pins)+data Port = Port { portNo :: Word8 -- ^ The port number+ }+ deriving (Eq, Ord)++instance Show Port where+ show p = "Port" ++ show (portNo p)++-- | A pin on the Arduino+data Pin = Pin { pinNo :: Word8 -- ^ The pin number+ }+ deriving (Eq, Ord)++instance Show Pin where+ show p | i < 10 = "Pin0" ++ show i+ | True = "Pin" ++ show i+ where i = pinNo p++-- | Declare a pin on the board by its number.+pin :: Word8 -> Pin+pin = Pin++-- | On the Arduino, pins are grouped into banks of 8.+-- Given a pin, this function determines which port it belongs to+pinPort :: Pin -> Port+pinPort p = Port (pinNo p `quot` 8)++-- | On the Arduino, pins are grouped into banks of 8.+-- Given a pin, this function determines which index it belongs to in its port+pinPortIndex :: Pin -> Word8+pinPortIndex p = pinNo p `rem` 8++-- | The mode for a pin.+data PinMode = INPUT -- ^ Digital input+ | OUTPUT -- ^ Digital output+ | ANALOG -- ^ Analog input+ | PWM -- ^ PWM (Pulse-Width-Modulation) output + | SERVO -- ^ Servo Motor controller+ | SHIFT -- ^ Shift controller+ | I2C -- ^ I2C (Inter-Integrated-Circuit) connection+ deriving (Eq, Show, Enum)++-- | A request, as sent to Arduino+data Request = QueryFirmware -- ^ Query the Firmata version installed+ | CapabilityQuery -- ^ Query the capabilities of the board+ | AnalogMappingQuery -- ^ Query the mapping of analog pins+ | SetPinMode Pin PinMode -- ^ Set the mode on a pin+ | DigitalReport Port Bool -- ^ Digital report values on port enable/disable+ | AnalogReport Pin Bool -- ^ Analog report values on pin enable/disable+ | DigitalPortWrite Port Word8 Word8 -- ^ Set the values on a port digitally+ deriving Show++-- | A response, as returned from the Arduino+data Response = Firmware Word8 Word8 String -- ^ Firmware version (maj/min and indentifier+ | Capabilities BoardCapabilities -- ^ Capabilities report+ | AnalogMapping [Word8] -- ^ Analog pin mappings+ | DigitalMessage Port Word8 Word8 -- ^ Status of a port+ | Unimplemented (Maybe String) [Word8] -- ^ Represents messages currently unsupported++instance Show Response where+ show (Firmware majV minV n) = "Firmware v" ++ show majV ++ "." ++ show minV ++ " (" ++ n ++ ")"+ show (Capabilities b) = "Capabilities:\n" ++ show b+ show (AnalogMapping bs) = "AnalogMapping: " ++ showByteList bs+ show (DigitalMessage p l h) = "DigitalMessage " ++ show p ++ " = " ++ showByte l ++ " " ++ showByte h+ show (Unimplemented mbc bs) = "Unimplemeneted " ++ fromMaybe "" mbc ++ " " ++ showByteList bs++-- | Resolution, as referred to in http://firmata.org/wiki/Protocol#Capability_Query+-- TODO: Not quite sure how this is used, so merely keep it as a Word8 now+type Resolution = Word8++-- | Capabilities of a pin+type PinCapabilities = ( Maybe Word8 -- Analog pin number, if any+ , [(PinMode, Resolution)]+ )++-- | What the board is capable of and current settings+newtype BoardCapabilities = BoardCapabilities (M.Map Pin PinCapabilities)++instance Show BoardCapabilities where+ show (BoardCapabilities m) = intercalate "\n" (map sh (M.toAscList m))+ where sh (p, (mbA, pc)) = show p ++ sep ++ unwords [show md | (md, _) <- pc]+ where sep = maybe ": " (\i -> "[A" ++ show i ++ "]: ") mbA++-- | Data associated with a pin+data PinData = PinData {+ pinMode :: PinMode+ , pinValue :: Maybe (Either Bool Int)+ }+ deriving Show++-- | State of the board+data BoardState = BoardState {+ analogReportingPins :: S.Set Pin -- ^ Which analog pins are reporting+ , digitalReportingPins :: S.Set Pin -- ^ Which digital pins are reporting+ , pinStates :: M.Map Pin PinData -- ^ For-each pin, store its data+ , digitalWakeUpQueue :: [MVar ()] -- ^ Semaphore list to wake-up upon receiving a digital message for this pin+ }++-- | State of the computation data ArduinoState = ArduinoState {- message :: String -> IO () -- ^ Current debugging routine- , port :: SerialPort -- ^ Port we are communicating on- , firmataID :: String -- ^ The ID of the board (as identified by the Board itself)- , deviceChannel :: Maybe ArduinoChannel -- ^ Communication channel+ message :: String -> IO () -- ^ Current debugging routine+ , port :: SerialPort -- ^ Serial port we are communicating on+ , firmataID :: String -- ^ The ID of the board (as identified by the Board itself)+ , capabilities :: BoardCapabilities -- ^ Capabilities of the board+ , boardState :: MVar BoardState -- ^ Current state of the board+ , deviceChannel :: Chan Response -- ^ Incoming messages from the board } -- | The Arduino monad. newtype Arduino a = Arduino (StateT ArduinoState IO a)- deriving (Functor, Monad, MonadIO, MonadState ArduinoState)+ deriving (Functor, Applicative, Monad, MonadIO, MonadState ArduinoState) --- | Retrieve the current channel.-getChannel :: Arduino ArduinoChannel-getChannel = fromMaybe die `fmap` gets deviceChannel- where die = error "Cannot communicate with the board!"+-- | Debugging only: print the given string on stdout.+debug :: String -> Arduino ()+debug s = do f <- gets message+ liftIO $ f s --- | Send down a request.-send :: Request -> Arduino ()-send r = do ArduinoChannel{sendChan} <- getChannel- liftIO $ sendChan r+-- | Which modes does this pin support?+getPinModes :: Pin -> Arduino [PinMode]+getPinModes p = do+ BoardCapabilities caps <- gets capabilities+ case p `M.lookup` caps of+ Nothing -> return []+ Just (_, ps) -> return (map fst ps) --- | Receive a sys-ex response.-recv :: Arduino Response-recv = do ArduinoChannel{recvChan} <- getChannel- liftIO recvChan+-- | Current state of the pin+getPinData :: Pin -> Arduino PinData+getPinData p = do+ bs <- gets boardState+ bst <- liftIO $ readMVar bs+ case p `M.lookup` pinStates bst of+ Nothing -> die ("Trying to access " ++ show p ++ " without proper configuration.")+ ["Make sure that you use 'setPinMode' to configure this pin first."]+ Just pd -> return pd --- | Receive a non-sys-ex response, that has /n/ bytes-recvN :: Int -> Arduino Response-recvN n = do ArduinoChannel{recvNChan} <- getChannel- liftIO $ recvNChan n+-- | Given a pin, collect the digital value corresponding to the+-- port it belongs to, where the new value of the current pin is given+-- The result is two bytes:+--+-- * First lsb: pins 0-6 on the port+-- * Second msb: pins 7-13 on the port+--+-- In particular, the result is suitable to be sent with a digital message+computePortData :: Pin -> Bool -> Arduino (Word8, Word8)+computePortData curPin newValue = do+ let curPort = pinPort curPin+ let curIndex = pinPortIndex curPin+ bs <- gets boardState+ liftIO $ modifyMVar bs $ \bst -> do+ let values = [(pinPortIndex p, pinValue pd) | (p, pd) <- M.assocs (pinStates bst), curPort == pinPort p, pinMode pd `elem` [INPUT, OUTPUT]]+ getVal i+ | i == curIndex = newValue+ | Just (Just (Left v)) <- i `lookup` values = v+ | True = False+ [b0, b1, b2, b3, b4, b5, b6, b7] = map getVal [0 .. 7]+ lsb = foldr (\(i, b) m -> if b then m `setBit` i else m) 0 (zip [0..] [b0, b1, b2, b3, b4, b5, b6])+ msb = foldr (\(i, b) m -> if b then m `setBit` (i-7) else m) 0 (zip [7..] [b7])+ -- update internal-value of the pin+ let bst' = bst {pinStates = M.insertWith (\_ o -> o{pinValue = Just (Left newValue)})+ curPin+ PinData{pinMode = OUTPUT, pinValue = Just (Left newValue)}+ (pinStates bst)}+ return (bst', (lsb, msb)) --- | Debugging only: print it on stdout.-debug :: String -> Arduino ()-debug s = do f <- gets message- liftIO $ f s+-- | Keep track of listeners on a digital message+digitalWakeUp :: MVar () -> Arduino ()+digitalWakeUp semaphore = do+ bs <- gets boardState+ liftIO $ modifyMVar_ bs $ \bst -> return bst{digitalWakeUpQueue = semaphore : digitalWakeUpQueue bst}++-- | Firmata commands, see: http://firmata.org/wiki/Protocol#Message_Types+data FirmataCmd = ANALOG_MESSAGE Pin -- ^ @0xE0@ pin+ | DIGITAL_MESSAGE Port -- ^ @0x90@ port+ | REPORT_ANALOG_PIN Pin -- ^ @0xC0@ pin+ | REPORT_DIGITAL_PORT Port -- ^ @0xD0@ port+ | START_SYSEX -- ^ @0xF0@+ | SET_PIN_MODE -- ^ @0xF4@+ | END_SYSEX -- ^ @0xF7@+ | PROTOCOL_VERSION -- ^ @0xF9@+ | SYSTEM_RESET -- ^ @0xFF@+ deriving Show++-- | Compute the numeric value of a command+firmataCmdVal :: FirmataCmd -> Word8+firmataCmdVal (ANALOG_MESSAGE p) = 0xE0 .|. pinNo p+firmataCmdVal (DIGITAL_MESSAGE p) = 0x90 .|. portNo p+firmataCmdVal (REPORT_ANALOG_PIN p) = 0xC0 .|. pinNo p+firmataCmdVal (REPORT_DIGITAL_PORT p) = 0xD0 .|. portNo p+firmataCmdVal START_SYSEX = 0xF0+firmataCmdVal SET_PIN_MODE = 0xF4+firmataCmdVal END_SYSEX = 0xF7+firmataCmdVal PROTOCOL_VERSION = 0xF9+firmataCmdVal SYSTEM_RESET = 0xFF++-- | Convert a byte to a Firmata command+getFirmataCmd :: Word8 -> Either Word8 FirmataCmd+getFirmataCmd w = classify+ where extract m | w .&. m == m = Just $ fromIntegral (w .&. 0x0F)+ | True = Nothing+ classify | w == 0xF0 = Right START_SYSEX+ | w == 0xF4 = Right SET_PIN_MODE+ | w == 0xF7 = Right END_SYSEX+ | w == 0xF9 = Right PROTOCOL_VERSION+ | w == 0xFF = Right SYSTEM_RESET+ | Just i <- extract 0xE0 = Right $ ANALOG_MESSAGE (Pin i)+ | Just i <- extract 0x90 = Right $ DIGITAL_MESSAGE (Port i)+ | Just i <- extract 0xC0 = Right $ REPORT_ANALOG_PIN (Pin i)+ | Just i <- extract 0xD0 = Right $ REPORT_DIGITAL_PORT (Port i)+ | True = Left w++-- | Sys-ex commands, see: http://firmata.org/wiki/Protocol#Sysex_Message_Format+data SysExCmd = RESERVED_COMMAND -- ^ @0x00@ 2nd SysEx data byte is a chip-specific command (AVR, PIC, TI, etc).+ | ANALOG_MAPPING_QUERY -- ^ @0x69@ ask for mapping of analog to pin numbers+ | ANALOG_MAPPING_RESPONSE -- ^ @0x6A@ reply with mapping info+ | CAPABILITY_QUERY -- ^ @0x6B@ ask for supported modes and resolution of all pins+ | CAPABILITY_RESPONSE -- ^ @0x6C@ reply with supported modes and resolution+ | PIN_STATE_QUERY -- ^ @0x6D@ ask for a pin's current mode and value+ | PIN_STATE_RESPONSE -- ^ @0x6E@ reply with a pin's current mode and value+ | EXTENDED_ANALOG -- ^ @0x6F@ analog write (PWM, Servo, etc) to any pin+ | SERVO_CONFIG -- ^ @0x70@ set max angle, minPulse, maxPulse, freq+ | STRING_DATA -- ^ @0x71@ a string message with 14-bits per char+ | SHIFT_DATA -- ^ @0x75@ shiftOut config/data message (34 bits)+ | I2C_REQUEST -- ^ @0x76@ I2C request messages from a host to an I/O board+ | I2C_REPLY -- ^ @0x77@ I2C reply messages from an I/O board to a host+ | I2C_CONFIG -- ^ @0x78@ Configure special I2C settings such as power pins and delay times+ | REPORT_FIRMWARE -- ^ @0x79@ report name and version of the firmware+ | SAMPLING_INTERVAL -- ^ @0x7A@ sampling interval+ | SYSEX_NON_REALTIME -- ^ @0x7E@ MIDI Reserved for non-realtime messages+ | SYSEX_REALTIME -- ^ @0x7F@ MIDI Reserved for realtime messages+ deriving Show++-- | Convert a 'SysExCmd' to a byte+sysExCmdVal :: SysExCmd -> Word8+sysExCmdVal RESERVED_COMMAND = 0x00+sysExCmdVal ANALOG_MAPPING_QUERY = 0x69+sysExCmdVal ANALOG_MAPPING_RESPONSE = 0x6A+sysExCmdVal CAPABILITY_QUERY = 0x6B+sysExCmdVal CAPABILITY_RESPONSE = 0x6C+sysExCmdVal PIN_STATE_QUERY = 0x6D+sysExCmdVal PIN_STATE_RESPONSE = 0x6E+sysExCmdVal EXTENDED_ANALOG = 0x6F+sysExCmdVal SERVO_CONFIG = 0x70+sysExCmdVal STRING_DATA = 0x71+sysExCmdVal SHIFT_DATA = 0x75+sysExCmdVal I2C_REQUEST = 0x76+sysExCmdVal I2C_REPLY = 0x77+sysExCmdVal I2C_CONFIG = 0x78+sysExCmdVal REPORT_FIRMWARE = 0x79+sysExCmdVal SAMPLING_INTERVAL = 0x7A+sysExCmdVal SYSEX_NON_REALTIME = 0x7E+sysExCmdVal SYSEX_REALTIME = 0x7F++-- | Convert a byte into a 'SysExCmd'+getSysExCommand :: Word8 -> Either Word8 SysExCmd+getSysExCommand 0x00 = Right RESERVED_COMMAND+getSysExCommand 0x69 = Right ANALOG_MAPPING_QUERY+getSysExCommand 0x6A = Right ANALOG_MAPPING_RESPONSE+getSysExCommand 0x6B = Right CAPABILITY_QUERY+getSysExCommand 0x6C = Right CAPABILITY_RESPONSE+getSysExCommand 0x6D = Right PIN_STATE_QUERY+getSysExCommand 0x6E = Right PIN_STATE_RESPONSE+getSysExCommand 0x6F = Right EXTENDED_ANALOG+getSysExCommand 0x70 = Right SERVO_CONFIG+getSysExCommand 0x71 = Right STRING_DATA+getSysExCommand 0x75 = Right SHIFT_DATA+getSysExCommand 0x76 = Right I2C_REQUEST+getSysExCommand 0x77 = Right I2C_REPLY+getSysExCommand 0x78 = Right I2C_CONFIG+getSysExCommand 0x79 = Right REPORT_FIRMWARE+getSysExCommand 0x7A = Right SAMPLING_INTERVAL+getSysExCommand 0x7E = Right SYSEX_NON_REALTIME+getSysExCommand 0x7F = Right SYSEX_REALTIME+getSysExCommand n = Left n++-- | Keep track of pin-mode changes+registerPinMode :: Pin -> PinMode -> Arduino [Request]+registerPinMode p m = do+ -- first check that the requested mode is supported for this pin+ BoardCapabilities caps <- gets capabilities+ case p `M.lookup` caps of+ Nothing+ -> die ("Invalid access to unsupported pin: " ++ show p)+ ("Available pins are: " : [" " ++ show k | (k, _) <- M.toAscList caps])+ Just (_, ms)+ | m `notElem` map fst ms+ -> die ("Invalid mode " ++ show m ++ " set for " ++ show p)+ ["Supported modes for this pin are: " ++ unwords (if null ms then ["NONE"] else map show ms)]+ _ -> return ()+ -- register the pin mode+ bs <- gets boardState+ liftIO $ modifyMVar_ bs $ \bst -> return bst{pinStates = M.insert p PinData{pinMode = m, pinValue = Nothing} (pinStates bst) }+ -- now return extra actions we need to take for this mode+ getModeActions p m++-- | Depending on a mode-set call, determine what further+-- actions should be executed, such as enabling/disabling pin/port reporting+getModeActions :: Pin -> PinMode -> Arduino [Request]+getModeActions p INPUT = do -- This pin is just configured for digital input+ bs <- gets boardState+ liftIO $ modifyMVar bs $ \bst -> do+ let aPins = analogReportingPins bst+ dPins = digitalReportingPins bst+ port = pinPort p+ acts1 = [AnalogReport p False | p `S.member` aPins] -- there was an analog report, remove it+ acts2 = [DigitalReport port True | port `notElem` map pinPort (S.elems dPins)] -- there was no digital report, add it+ bst' = bst { analogReportingPins = p `S.delete` analogReportingPins bst+ , digitalReportingPins = p `S.insert` digitalReportingPins bst+ }+ return (bst', acts1 ++ acts2)+getModeActions p ANALOG = do -- This pin just configured for analog+ bs <- gets boardState+ liftIO $ modifyMVar bs $ \bst -> do+ let aPins = analogReportingPins bst+ dPins = p `S.delete` digitalReportingPins bst+ port = pinPort p+ acts1 = [AnalogReport p True | p `S.notMember` aPins] -- there was no analog report, add it+ acts2 = [DigitalReport port False | port `notElem` map pinPort (S.elems dPins)] -- no need for a digital report, remove it+ bst' = bst { analogReportingPins = p `S.insert` analogReportingPins bst+ , digitalReportingPins = dPins+ }+ return (bst', acts1 ++ acts2)+getModeActions _ _ = return []
System/Hardware/Arduino/Examples/Blink.hs view
@@ -13,6 +13,8 @@ import Control.Monad (forever) import Control.Monad.Trans (liftIO)+import System.IO (hSetBuffering, BufferMode(NoBuffering), stdout)+ import System.Hardware.Arduino -- | Blink the led connected to port 13 on the Arduino UNO board.@@ -24,6 +26,7 @@ -- a useful diagnostic message. blink :: IO () blink = withArduino False "/dev/cu.usbmodemfd131" $ do+ liftIO $ hSetBuffering stdout NoBuffering let led = pin 13 setPinMode led OUTPUT forever $ do liftIO $ putStr "."
+ System/Hardware/Arduino/Examples/Switch.hs view
@@ -0,0 +1,49 @@+-------------------------------------------------------------------------------+-- |+-- Module : System.Hardware.Arduino.Examples.Switch+-- Copyright : (c) Levent Erkok+-- License : BSD3+-- Maintainer : erkokl@gmail.com+-- Stability : experimental+--+-- Reads the value of a push-button switch and displays it continuously+-------------------------------------------------------------------------------++module System.Hardware.Arduino.Examples.Switch where++import Control.Monad.Trans (liftIO)+import System.IO (hSetBuffering, BufferMode(NoBuffering), stdout)++import System.Hardware.Arduino++-- | Read the value of a push-button switch (NO - normally open)+-- connected to input pin 2 on the Arduino. We will continuously+-- monitor and print the value as it changes. Also, we'll turn+-- the led on pin 7 on when the switch is pressed.+--+-- The wiring diagram is fairly straightforward:+--+-- Switch: ~10K pull-down resistor, between pin 2 and GND+-- Push-button NO-switch (normally open) between pin-2 and 5V+--+-- Led : ~10K pull-down resistor between pin-7 and led++-- Led between GND and the resistor+--+-- Don't neglect the resistors to make sure you don't do a short-circuit!+switch :: IO ()+switch = withArduino False "/dev/cu.usbmodemfd131" $ do+ liftIO $ hSetBuffering stdout NoBuffering+ setPinMode led OUTPUT+ setPinMode button INPUT+ current <- digitalRead button+ report (not current) current+ go current+ where button = pin 2+ led = pin 7+ report prev new+ | prev /= new = do liftIO $ putStrLn $ "Button is currently " ++ if new then "ON" else "OFF"+ digitalWrite led new+ | True = return ()+ go prev = do new <- waitFor button+ report prev new+ go new
System/Hardware/Arduino/Firmata/Basics.hs view
@@ -12,13 +12,13 @@ {-# LANGUAGE NamedFieldPuns #-} module System.Hardware.Arduino.Firmata.Basics where +import Control.Concurrent (newEmptyMVar, readMVar)+import Control.Monad (when) import Control.Monad.Trans (liftIO) import Data.Word (Word8)-import Data.Bits (shiftL) import System.Hardware.Arduino.Data-import System.Hardware.Arduino.Parts-import System.Hardware.Arduino.Protocol+import System.Hardware.Arduino.Comm import qualified System.Hardware.Arduino.Utils as U -- | Retrieve the Firmata firmware version running on the Arduino. The first@@ -30,36 +30,64 @@ r <- recv case r of Firmware v1 v2 m -> return (v1, v2, m)- _ -> error $ "Got unexpected response for query firmware call: " ++ show r+ _ -> error $ "queryFirmware: Got unexpected response for query firmware call: " ++ show r --- | Delay the computaton for a given number of milli-seconds.+-- | Delay the computaton for a given number of milli-seconds delay :: Int -> Arduino () delay = liftIO . U.delay --- | Set the mode on a particular pin on the board.+-- | Set the mode on a particular pin on the board setPinMode :: Pin -> PinMode -> Arduino ()-setPinMode p m = send $ SetPinMode p m---- | Read the value of a pin in digital mode.-digitalRead :: Pin -> Arduino (PinMode, Bool)-digitalRead p = do- send $ DigitalRead p- r <- recv- case r of- DigitalPinState p' m b -> if p == p'- then return (m, b)- else error $ "Got unexpected response for " ++ show p' ++ " instead of " ++ show p- _ -> error $ "Got unexpected response for query DigitalRead: " ++ show r+setPinMode p m = do+ extras <- registerPinMode p m+ send $ SetPinMode p m+ mapM_ send extras --- | Set or clear a particular digital pin on the board.+-- | Set or clear a digital pin on the board digitalWrite :: Pin -> Bool -> Arduino () digitalWrite p v = do- let (port, idx) = pinPort p- dr n- | n > 2 && n < 14 = digitalRead (pin n)- | True = return (OUTPUT, False)- oldVal <- map snd `fmap` mapM dr [port * 8 + i | i <- [0 .. 7]]- let [b0, b1, b2, b3, b4, b5, b6, b7] = [if i == idx then v else old | (old, i) <- zip oldVal [0 ..]]- lsb = sum [1 `shiftL` i | (True, i) <- zip [b0, b1, b2, b3, b4, b5, b6, False] [0 .. 7]]- msb = if b7 then 1 else 0- send $ DigitalPortWrite port lsb msb+ -- first make sure we have this pin set as output+ pd <- getPinData p+ when (pinMode pd /= OUTPUT) $ U.die ("Invalid digitalWrite call on pin " ++ show p)+ [ "The current mode for this pin is: " ++ show (pinMode pd)+ , "For digitalWrite, it must be set to: " ++ show OUTPUT+ , "via a proper call to setPinMode"+ ]+ (lsb, msb) <- computePortData p v+ send $ DigitalPortWrite (pinPort p) lsb msb++-- | Read the value of a pin in digital mode; this is a non-blocking call, returning+-- the current value immediately. See 'waitFor' for a version that waits for a change+-- in the pin first.+digitalRead :: Pin -> Arduino Bool+digitalRead p = do+ -- first make sure we have this pin set as input+ pd <- getPinData p+ when (pinMode pd /= INPUT) $ U.die ("Invalid digitalRead call on pin " ++ show p)+ [ "The current mode for this pin is: " ++ show (pinMode pd)+ , "For digitalWrite, it must be set to: " ++ show INPUT+ , "via a proper call to setPinMode"+ ]+ return $ case pinValue pd of+ Just (Left v) -> v+ _ -> False -- no (correctly-typed) value reported yet, default to False++-- | Wait for a change in the value of the digital input pin. Returns the new value.+-- Note that this is a blocking call. For a non-blocking version, see 'digitalRead', which returns the current+-- value of a pin immediately.+waitFor :: Pin -> Arduino Bool+waitFor p = do+ curVal <- digitalRead p+ let wait = do sleepTillDigitalMessage+ newVal <- digitalRead p+ if newVal == curVal+ then wait+ else return newVal+ wait++-- | Sleep until we receive a digital message from the board+sleepTillDigitalMessage :: Arduino ()+sleepTillDigitalMessage = do+ semaphore <- liftIO newEmptyMVar+ digitalWakeUp semaphore+ liftIO $ readMVar semaphore
− System/Hardware/Arduino/Parts.hs
@@ -1,45 +0,0 @@----------------------------------------------------------------------------------- |--- Module : System.Hardware.Arduino.Firmata.Parts--- Copyright : (c) Levent Erkok--- License : BSD3--- Maintainer : erkokl@gmail.com--- Stability : experimental------ Basic Arduino hardware abstractions, pins etc.----------------------------------------------------------------------------------module System.Hardware.Arduino.Parts(PinMode(..), Pin, pin, pinNo, pinPort) where---- | A pin on the Arduino-data Pin = Pin { pinNo :: Int -- ^ The pin number- }- deriving Eq--instance Show Pin where- show p | i < 10 = "Pin0" ++ show i- | True = "Pin" ++ show i- where i = pinNo p---- | Smart constructor for a pin. The input should be between 1 and 13:------ * Pins 0-1 are reserved for TX/RX; so can't be directly used.------ * 13 pins is UNO specific, we will need to expand this definition if--- we start supporting other boards.-pin :: Int -> Pin-pin i | i < 2 || i > 13 = error $ "Invalid pin number: " ++ show i- | True = Pin i---- | On the Arduino, pins are grouped into banks of 8.--- Given a pin, this function determines which port/index it belongs to-pinPort :: Pin -> (Int, Int)-pinPort p = pinNo p `quotRem` 8---- | The mode for a pin.-data PinMode = INPUT- | OUTPUT- | ANALOG- | PWM- | SERVO- deriving (Show, Enum)
System/Hardware/Arduino/Protocol.hs view
@@ -9,89 +9,70 @@ -- Internal representation of the firmata protocol. ------------------------------------------------------------------------------- -module System.Hardware.Arduino.Protocol(Request(..), Response(..), package, unpackage) where+module System.Hardware.Arduino.Protocol(package, unpackageSysEx, unpackageNonSysEx) where -import Data.Bits ((.|.), (.&.), shiftL)-import Data.Char (chr)-import Data.List (intercalate)-import Data.Word (Word8, Word16)+import Data.Word (Word8) import qualified Data.ByteString as B+import qualified Data.Map as M -import System.Hardware.Arduino.Parts+import System.Hardware.Arduino.Data import System.Hardware.Arduino.Utils --- | A request, as sent to Arduino-data Request = QueryFirmware -- ^ Query the Firmata version installed- | SetPinMode Pin PinMode -- ^ Set a pin to a particular mode- | DigitalRead Pin -- ^ Read the value of a given pin- | DigitalPortWrite Int Word8 Word8 -- ^ Write the values of pins on the given port; 2 bytes lo/hi--instance Show Request where- show QueryFirmware = "QueryFirmWare"- show (SetPinMode p m) = "SetPinMode " ++ show p ++ " to " ++ show m- show (DigitalRead p) = "DigitalRead " ++ show p- show (DigitalPortWrite p l h) = "DigitalWrite " ++ show p ++ " to " ++ showBin l ++ "_" ++ showBin h---- | A response, as returned from the Arduino-data Response = Firmware Word8 Word8 String -- ^ Firmware version (maj/min and indentifier- | DigitalPinState Pin PinMode Bool -- ^ State of a given pin- | DigitalPortState Int Word16 -- ^ State of a given port- | Unknown [Word8] -- ^ Represents messages currently unsupported--instance Show Response where- show (Firmware majV minV n) = "Firmware v" ++ show majV ++ "." ++ show minV ++ " (" ++ n ++ ")"- show (DigitalPinState p m v) = "DigitalPinState " ++ show p ++ "(" ++ show m ++ ") = " ++ if v then "HIGH" else "LOW"- show (DigitalPortState p w) = "DigitalPortState " ++ show p ++ " = " ++ show w- show (Unknown bs) = "Unknown [" ++ intercalate ", " (map showByte bs) ++ "]"---- | Marker for the start of a sys-ex message-cdStart :: Word8-cdStart = 0xf0---- | Marker for the end of a sys-ex message-cdEnd :: Word8-cdEnd = 0xf7- -- | Wrap a sys-ex message to be sent to the board-sysEx :: [Word8] -> B.ByteString-sysEx bs = B.pack $ cdStart : bs ++ [cdEnd]+sysEx :: SysExCmd -> [Word8] -> B.ByteString+sysEx cmd bs = B.pack $ firmataCmdVal START_SYSEX+ : sysExCmdVal cmd+ : bs+ ++ [firmataCmdVal END_SYSEX] +-- | Construct a non sys-ex message+nonSysEx :: FirmataCmd -> [Word8] -> B.ByteString+nonSysEx cmd bs = B.pack $ firmataCmdVal cmd : bs+ -- | Package a request as a sequence of bytes to be sent to the board -- using the Firmata protocol. package :: Request -> B.ByteString-package QueryFirmware = sysEx [0x79]-package (SetPinMode p m) = B.pack [0xf4, fromIntegral (pinNo p), fromIntegral (fromEnum m)]-package (DigitalRead p) = sysEx [0x6d, fromIntegral (pinNo p)]-package (DigitalPortWrite p l m) = B.pack [0x90 .|. fromIntegral p, l, m]+package QueryFirmware = sysEx REPORT_FIRMWARE []+package CapabilityQuery = sysEx CAPABILITY_QUERY []+package AnalogMappingQuery = sysEx ANALOG_MAPPING_QUERY []+package (AnalogReport p b) = nonSysEx (REPORT_ANALOG_PIN p) [if b then 1 else 0]+package (DigitalReport p b) = nonSysEx (REPORT_DIGITAL_PORT p) [if b then 1 else 0]+package (SetPinMode p m) = nonSysEx SET_PIN_MODE [fromIntegral (pinNo p), fromIntegral (fromEnum m)]+package (DigitalPortWrite p l m) = nonSysEx (DIGITAL_MESSAGE p) [l, m] --- | Unpackage a series of bytes as received from the board into a Response-unpackage :: B.ByteString -> Response-unpackage inp- | length bs < 2 || head bs /= cdStart || last bs /= cdEnd- = Unknown bs+-- | Unpackage a SysEx response+unpackageSysEx :: [Word8] -> Response+unpackageSysEx [] = Unimplemented (Just "<EMPTY-SYSEX-CMD>") []+unpackageSysEx (cmdWord:args)+ | Right cmd <- getSysExCommand cmdWord+ = case (cmd, args) of+ (REPORT_FIRMWARE, majV : minV : rest) -> Firmware majV minV (getString rest)+ (CAPABILITY_RESPONSE, bs) -> Capabilities (getCapabilities bs)+ (ANALOG_MAPPING_RESPONSE, bs) -> AnalogMapping bs+ _ -> Unimplemented (Just (show cmd)) args | True- = getResponse (init (tail bs))- where bs = B.unpack inp+ = Unimplemented Nothing (cmdWord : args) --- | Parse a response message. TBD: Use a proper (cereal based?) parser.-getResponse :: [Word8] -> Response-getResponse (rf : majV : minV : rest)- | rf == 0x79- = Firmware majV minV (getString rest)-getResponse (pr : curPin : pinMode : pinState : [])- | pr == 0x6e- = DigitalPinState (pin (fromIntegral curPin)) (toEnum (fromIntegral pinMode)) (pinState /= 0)-getResponse (dpr : vL : vH : [])- | dpr .&. 0xF0 == 0x90- = let port = fromIntegral (dpr .&. 0x0F)- w = fromIntegral ((vH .&. 0x7F) `shiftL` 8) .|. fromIntegral (vL .&. 0x7F)- in DigitalPortState port w-getResponse bs = Unknown bs+getCapabilities :: [Word8] -> BoardCapabilities+getCapabilities bs = BoardCapabilities $ M.fromList $ zipWith (\p c -> (p, (Nothing, c))) (map pin [0..]) (map pinCaps (chunk bs))+ where chunk xs = case break (== 0x7f) xs of+ ([], []) -> []+ (cur, 0x7f:rest) -> cur : chunk rest+ _ -> [xs]+ pinCaps (x:y:rest) = (toEnum (fromIntegral x), y) : pinCaps rest+ pinCaps _ = [] --- | Turn a lo/hi encoded Arduino string constant into a Haskell string-getString :: [Word8] -> String-getString [] = ""-getString [a] = [chr (fromIntegral a)] -- shouldn't happen, but no need to error out either-getString (l:h:rest) = c : getString rest- where c = chr $ fromIntegral $ h `shiftL` 8 .|. l+-- | Unpackage a Non-SysEx response+unpackageNonSysEx :: (Int -> IO [Word8]) -> FirmataCmd -> IO Response+unpackageNonSysEx getBytes c = grab c+ where unimplemented n = Unimplemented (Just (show c)) `fmap` getBytes n+ grab (ANALOG_MESSAGE _pin) = unimplemented 2+ grab (DIGITAL_MESSAGE p) = getBytes 2 >>= \[l, h] -> return (DigitalMessage p l h)+ grab (REPORT_ANALOG_PIN _pin) = unimplemented 1+ grab (REPORT_DIGITAL_PORT _port) = unimplemented 1+ grab START_SYSEX = unimplemented 0 -- we should never see this+ grab SET_PIN_MODE = unimplemented 2+ grab END_SYSEX = unimplemented 0 -- we should never see this+ grab PROTOCOL_VERSION = unimplemented 2+ grab SYSTEM_RESET = unimplemented 0
System/Hardware/Arduino/Utils.hs view
@@ -12,8 +12,10 @@ import Control.Concurrent (threadDelay) import Control.Monad (void)+import Data.Bits ((.|.), shiftL) import Data.Char (isAlphaNum, isAscii, isSpace, chr) import Data.IORef (newIORef, readIORef, writeIORef)+import Data.List (intercalate) import Data.Word (Word8) import System.Process (system) import System.Info (os)@@ -47,6 +49,21 @@ where c = chr $ fromIntegral i isVisible = isAscii c && isAlphaNum c && isSpace c +-- | Show a list of bytes+showByteList :: [Word8] -> String+showByteList bs = "[" ++ intercalate ", " (map showByte bs) ++ "]"+ -- | Show a number as a binary value showBin :: (Integral a, Show a) => a -> String showBin n = showIntAtBase 2 (head . show) n ""++-- | Turn a lo/hi encoded Arduino string constant into a Haskell string+getString :: [Word8] -> String+getString [] = ""+getString [a] = [chr (fromIntegral a)] -- shouldn't happen, but no need to error out either+getString (l:h:rest) = c : getString rest+ where c = chr $ fromIntegral $ h `shiftL` 8 .|. l++-- | Error out+die :: String -> [String] -> a+die m ms = error $ "\n*** hArduino:ERROR: " ++ intercalate "\n*** " (m:ms)
hArduino.cabal view
@@ -1,5 +1,5 @@ Name: hArduino-Version: 0.1+Version: 0.2 Category: Hardware Synopsis: Control your Arduino board from Haskell. Description: Control Arduino from Haskell, using the Firmata protocol.@@ -31,15 +31,17 @@ Library default-language: Haskell2010 ghc-options : -Wall--- NB. process is only needed for "sleep", since--- threaddelay is broken on Mac. See: http://hackage.haskell.org/trac/ghc/ticket/7299- Build-depends : base >= 4 && < 5, serialport, bytestring, mtl, process+ Build-depends : base >= 4 && < 5, serialport, bytestring+ , mtl , unix, containers+ -- NB. process is only needed for "sleep", since+ -- threaddelay is broken on Mac. See: http://hackage.haskell.org/trac/ghc/ticket/7299+ , process Exposed-modules : System.Hardware.Arduino , System.Hardware.Arduino.Examples.Blink+ , System.Hardware.Arduino.Examples.Switch Other-modules : System.Hardware.Arduino.Comm , System.Hardware.Arduino.Data , System.Hardware.Arduino.Firmata , System.Hardware.Arduino.Firmata.Basics , System.Hardware.Arduino.Protocol- , System.Hardware.Arduino.Parts , System.Hardware.Arduino.Utils