module System.Hardware.Arduino.Data where
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 qualified Data.Map as M
import qualified Data.Set as S
import System.Hardware.Arduino.Utils
data Port = Port { portNo :: Word8
}
deriving (Eq, Ord)
instance Show Port where
show p = "Port" ++ show (portNo p)
data Pin = Pin { pinNo :: Word8
}
deriving (Eq, Ord)
instance Show Pin where
show p | i < 10 = "Pin0" ++ show i
| True = "Pin" ++ show i
where i = pinNo p
pin :: Word8 -> Pin
pin = Pin
pinPort :: Pin -> Port
pinPort p = Port (pinNo p `quot` 8)
pinPortIndex :: Pin -> Word8
pinPortIndex p = pinNo p `rem` 8
data PinMode = INPUT
| OUTPUT
| ANALOG
| PWM
| SERVO
| SHIFT
| I2C
deriving (Eq, Show, Enum)
data Request = QueryFirmware
| CapabilityQuery
| AnalogMappingQuery
| SetPinMode Pin PinMode
| DigitalReport Port Bool
| AnalogReport Pin Bool
| DigitalPortWrite Port Word8 Word8
deriving Show
data Response = Firmware Word8 Word8 String
| Capabilities BoardCapabilities
| AnalogMapping [Word8]
| DigitalMessage Port Word8 Word8
| Unimplemented (Maybe String) [Word8]
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
type Resolution = Word8
type PinCapabilities = ( Maybe Word8
, [(PinMode, Resolution)]
)
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 PinData = PinData {
pinMode :: PinMode
, pinValue :: Maybe (Either Bool Int)
}
deriving Show
data BoardState = BoardState {
analogReportingPins :: S.Set Pin
, digitalReportingPins :: S.Set Pin
, pinStates :: M.Map Pin PinData
, digitalWakeUpQueue :: [MVar ()]
}
data ArduinoState = ArduinoState {
message :: String -> IO ()
, port :: SerialPort
, firmataID :: String
, capabilities :: BoardCapabilities
, boardState :: MVar BoardState
, deviceChannel :: Chan Response
}
newtype Arduino a = Arduino (StateT ArduinoState IO a)
deriving (Functor, Applicative, Monad, MonadIO, MonadState ArduinoState)
debug :: String -> Arduino ()
debug s = do f <- gets message
liftIO $ f s
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)
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
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` (i7) else m) 0 (zip [7..] [b7])
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))
digitalWakeUp :: MVar () -> Arduino ()
digitalWakeUp semaphore = do
bs <- gets boardState
liftIO $ modifyMVar_ bs $ \bst -> return bst{digitalWakeUpQueue = semaphore : digitalWakeUpQueue bst}
data FirmataCmd = ANALOG_MESSAGE Pin
| DIGITAL_MESSAGE Port
| REPORT_ANALOG_PIN Pin
| REPORT_DIGITAL_PORT Port
| START_SYSEX
| SET_PIN_MODE
| END_SYSEX
| PROTOCOL_VERSION
| SYSTEM_RESET
deriving Show
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
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
data SysExCmd = RESERVED_COMMAND
| ANALOG_MAPPING_QUERY
| ANALOG_MAPPING_RESPONSE
| CAPABILITY_QUERY
| CAPABILITY_RESPONSE
| PIN_STATE_QUERY
| PIN_STATE_RESPONSE
| EXTENDED_ANALOG
| SERVO_CONFIG
| STRING_DATA
| SHIFT_DATA
| I2C_REQUEST
| I2C_REPLY
| I2C_CONFIG
| REPORT_FIRMWARE
| SAMPLING_INTERVAL
| SYSEX_NON_REALTIME
| SYSEX_REALTIME
deriving Show
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
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
registerPinMode :: Pin -> PinMode -> Arduino [Request]
registerPinMode p m = do
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 ()
bs <- gets boardState
liftIO $ modifyMVar_ bs $ \bst -> return bst{pinStates = M.insert p PinData{pinMode = m, pinValue = Nothing} (pinStates bst) }
getModeActions p m
getModeActions :: Pin -> PinMode -> Arduino [Request]
getModeActions p INPUT = do
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]
acts2 = [DigitalReport port True | port `notElem` map pinPort (S.elems dPins)]
bst' = bst { analogReportingPins = p `S.delete` analogReportingPins bst
, digitalReportingPins = p `S.insert` digitalReportingPins bst
}
return (bst', acts1 ++ acts2)
getModeActions p ANALOG = do
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]
acts2 = [DigitalReport port False | port `notElem` map pinPort (S.elems dPins)]
bst' = bst { analogReportingPins = p `S.insert` analogReportingPins bst
, digitalReportingPins = dPins
}
return (bst', acts1 ++ acts2)
getModeActions _ _ = return []