module System.Hardware.Arduino.Data where
import Control.Concurrent (Chan, MVar, modifyMVar, modifyMVar_, withMVar, ThreadId)
import Control.Monad (when)
import Control.Monad.State (StateT, MonadIO, MonadState, gets, liftIO)
import Data.Bits ((.&.), (.|.), setBit)
import Data.List (intercalate)
import Data.Maybe (fromMaybe, listToMaybe)
import Data.Word (Word8, Word32)
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 = DigitalPin {userPinNo :: Word8}
| AnalogPin {userPinNo :: Word8}
| MixedPin {userPinNo :: Word8}
instance Show Pin where
show (DigitalPin w) = "DPin" ++ show w
show (AnalogPin w) = "APin" ++ show w
show (MixedPin w) = "Pin" ++ show w
data IPin = InternalPin { pinNo :: Word8 }
deriving (Eq, Ord)
instance Show IPin where
show (InternalPin w) = "IPin" ++ show w
pin :: Word8 -> Pin
pin = MixedPin
digital :: Word8 -> Pin
digital = DigitalPin
analog :: Word8 -> Pin
analog = AnalogPin
pinPort :: IPin -> Port
pinPort p = Port (pinNo p `quot` 8)
pinPortIndex :: IPin -> Word8
pinPortIndex p = pinNo p `rem` 8
data PinMode = INPUT
| OUTPUT
| ANALOG
| PWM
| SERVO
| SHIFT
| I2C
| ONEWIRE
| STEPPER
| ENCODER
| SERIAL
| PULLUP
| UNSUPPORTED
deriving (Eq, Show, Enum)
data Request = SystemReset
| QueryFirmware
| CapabilityQuery
| AnalogMappingQuery
| SetPinMode IPin PinMode
| DigitalReport Port Bool
| AnalogReport IPin Bool
| DigitalPortWrite Port Word8 Word8
| AnalogPinWrite IPin Word8 Word8
| SamplingInterval Word8 Word8
| Pulse IPin Bool Word32 Word32
deriving Show
data Response = Firmware Word8 Word8 String
| Capabilities BoardCapabilities
| AnalogMapping [Word8]
| DigitalMessage Port Word8 Word8
| AnalogMessage IPin Word8 Word8
| PulseResponse IPin Word32
| 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 (AnalogMessage p l h) = "AnalogMessage " ++ show p ++ " = " ++ showByte l ++ " " ++ showByte h
show (PulseResponse p v) = "PulseResponse " ++ show p ++ " = " ++ show v ++ " (microseconds)"
show (Unimplemented mbc bs) = "Unimplemeneted " ++ fromMaybe "" mbc ++ " " ++ showByteList bs
type Resolution = Word8
data PinCapabilities = PinCapabilities {
analogPinNumber :: Maybe Word8
, allowedModes :: [(PinMode, Resolution)]
}
newtype BoardCapabilities = BoardCapabilities (M.Map IPin PinCapabilities)
instance Show BoardCapabilities where
show (BoardCapabilities m) = intercalate "\n" (map sh (M.toAscList m))
where sh (p, PinCapabilities{analogPinNumber, allowedModes}) = show p ++ sep ++ unwords [show md | (md, _) <- allowedModes]
where sep = maybe ": " (\i -> "[A" ++ show i ++ "]: ") analogPinNumber
data PinData = PinData {
pinMode :: PinMode
, pinValue :: Maybe (Either Bool Int)
}
deriving Show
newtype LCD = LCD Int
deriving (Eq, Ord, Show)
data LCDController = Hitachi44780 {
lcdRS :: Pin
, lcdEN :: Pin
, lcdD4 :: Pin
, lcdD5 :: Pin
, lcdD6 :: Pin
, lcdD7 :: Pin
, lcdRows :: Int
, lcdCols :: Int
, dotMode5x10 :: Bool
}
deriving Show
data LCDData = LCDData {
lcdDisplayMode :: Word8
, lcdDisplayControl :: Word8
, lcdGlyphCount :: Word8
, lcdController :: LCDController
}
data BoardState = BoardState {
boardCapabilities :: BoardCapabilities
, analogReportingPins :: S.Set IPin
, digitalReportingPins :: S.Set IPin
, pinStates :: M.Map IPin PinData
, digitalWakeUpQueue :: [MVar ()]
, lcds :: M.Map LCD LCDData
}
data ArduinoState = ArduinoState {
message :: String -> IO ()
, bailOut :: forall a. String -> [String] -> IO a
, port :: SerialPort
, firmataID :: String
, boardState :: MVar BoardState
, deviceChannel :: Chan Response
, capabilities :: BoardCapabilities
, listenerTid :: MVar ThreadId
}
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
die :: String -> [String] -> Arduino a
die m ms = do f <- gets bailOut
liftIO $ f m ms
getPinModes :: IPin -> Arduino [PinMode]
getPinModes p = do
BoardCapabilities caps <- gets capabilities
case p `M.lookup` caps of
Nothing -> return []
Just PinCapabilities{allowedModes} -> return $ map fst allowedModes
getPinData :: IPin -> Arduino PinData
getPinData p = do
bs <- gets boardState
err <- gets bailOut
liftIO $ withMVar bs $ \bst ->
case p `M.lookup` pinStates bst of
Nothing -> err ("Trying to access " ++ show p ++ " without proper configuration.")
["Make sure that you use 'setPinMode' to configure this pin first."]
Just pd -> return pd
computePortData :: IPin -> 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])
bst' = bst{pinStates = M.insert 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 IPin
| DIGITAL_MESSAGE Port
| REPORT_ANALOG_PIN IPin
| 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 (InternalPin i)
| Just i <- extract 0x90 = Right $ DIGITAL_MESSAGE (Port i)
| Just i <- extract 0xC0 = Right $ REPORT_ANALOG_PIN (InternalPin 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
| PULSE
| 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 PULSE = 0x74
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 0x74 = Right PULSE
getSysExCommand n = Left n
registerPinMode :: IPin -> 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 PinCapabilities{allowedModes}
| m `notElem` map fst allowedModes
-> die ("Invalid mode " ++ show m ++ " set for " ++ show p)
["Supported modes for this pin are: " ++ unwords (if null allowedModes then ["NONE"] else map show allowedModes)]
_ -> return ()
bs <- gets boardState
mbOldMode <- liftIO $ withMVar bs $ \bst ->
case p `M.lookup` pinStates bst of
Nothing -> return Nothing
Just pd -> return $ Just $ pinMode pd
let registerNewMode = modifyMVar_ bs $ \bst -> return bst{pinStates = M.insert p PinData{pinMode = m, pinValue = Nothing} (pinStates bst) }
case mbOldMode of
Nothing -> do liftIO registerNewMode
getModeActions p m
Just m' | m == m' -> return []
| True -> do liftIO registerNewMode
remActs <- getRemovalActions p m'
addActs <- getModeActions p m
return $ remActs ++ addActs
getRemovalActions :: IPin -> PinMode -> Arduino [Request]
getRemovalActions p INPUT = do
bs <- gets boardState
liftIO $ modifyMVar bs $ \bst -> do
let dPins = p `S.delete` digitalReportingPins bst
port = pinPort p
acts = [DigitalReport port False | port `notElem` map pinPort (S.elems dPins)]
bst' = bst { digitalReportingPins = dPins }
return (bst', acts)
getRemovalActions p ANALOG = do
bs <- gets boardState
liftIO $ modifyMVar bs $ \bst -> do
let aPins = analogReportingPins bst
acts = [AnalogReport p False | p `S.member` aPins]
bst' = bst { analogReportingPins = p `S.delete` aPins }
return (bst', acts)
getRemovalActions _ OUTPUT = return []
getRemovalActions p m = die ("hArduino: getRemovalActions: TBD: Unsupported mode: " ++ show m) ["On pin " ++ show p]
getModeActions :: IPin -> 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 _ PWM = return []
getModeActions _ OUTPUT = return []
getModeActions _ SERVO = return []
getModeActions p m = die ("hArduino: getModeActions: TBD: Unsupported mode: " ++ show m) ["On pin " ++ show p]
getInternalPin :: Pin -> Arduino IPin
getInternalPin (MixedPin p) = return $ InternalPin p
getInternalPin (DigitalPin p) = return $ InternalPin p
getInternalPin (AnalogPin p)
= do BoardCapabilities caps <- gets capabilities
case listToMaybe [realPin | (realPin, PinCapabilities{analogPinNumber = Just n}) <- M.toAscList caps, p == n] of
Nothing -> die ("hArduino: " ++ show p ++ " is not a valid analog-pin on this board.")
["Hint: To refer to analog pin number k, simply use 'pin k', not 'pin (k+noOfDigitalPins)'" | p > 13]
Just rp -> return rp
convertAndCheckPin :: String -> Pin -> PinMode -> Arduino (IPin, PinData)
convertAndCheckPin what p' m = do
p <- getInternalPin p'
pd <- getPinData p
let user = userPinNo p'
board = pinNo p
bInfo
| user == board = ""
| True = " (On board " ++ show p ++ ")"
when (pinMode pd /= m) $ die ("Invalid " ++ what ++ " call on pin " ++ show p' ++ bInfo)
[ "The current mode for this pin is: " ++ show (pinMode pd)
, "For " ++ what ++ ", it must be set to: " ++ show m
, "via a proper call to setPinMode"
]
return (p, pd)