hArduino 0.2 → 0.3

raw patch · 21 files changed

+1183/−298 lines, 21 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGES.md +30/−0
• INSTALL +2/−7
• README +0/−1
• README.md +1/−0
• RELEASENOTES +0/−18
• System/Hardware/Arduino.hs +17/−9
• System/Hardware/Arduino/Comm.hs +99/−39
• System/Hardware/Arduino/Data.hs +98/−27
• System/Hardware/Arduino/Examples/Blink.hs +0/−36
• System/Hardware/Arduino/Examples/Switch.hs +0/−49
• System/Hardware/Arduino/Firmata.hs +160/−6
• System/Hardware/Arduino/Firmata/Basics.hs +0/−93
• System/Hardware/Arduino/LCD.hs +432/−0
• System/Hardware/Arduino/Protocol.hs +7/−3
• System/Hardware/Arduino/SamplePrograms/Analog.hs +43/−0
• System/Hardware/Arduino/SamplePrograms/Blink.hs +33/−0
• System/Hardware/Arduino/SamplePrograms/Button.hs +38/−0
• System/Hardware/Arduino/SamplePrograms/Counter.hs +46/−0
• System/Hardware/Arduino/SamplePrograms/LCD.hs +166/−0
• System/Hardware/Arduino/Utils.hs +1/−5
• hArduino.cabal +10/−5

@@ -0,0 +1,30 @@+* Hackage: (http://hackage.haskell.org/package/hArduino)+* GitHub:  (http://leventerkok.github.com/hArduino)++* Latest Hackage released version: 0.3++### Version 0.3, 2013-02-10++ * Library+    * Add support for pull-up resistors+    * Implement routines for waiting on digital triggers+    * Add support for reading analog values and setting sampling frequency.+    * Add support for LCDs (based on the Hitachi 44780 chip)+    * Better handling for Ctrl-C interrupts+ * Examples+    * Add counter: use push buttons to count up and down+    * Add analog-reading example+    * Add LCD controller example+    * Add wiring schematics for all sample programs++### Version 0.2, 2013-01-28++ * Rewrite the communication engine+ * Digital input/output implementation+ * Add switch example++### Version 0.1, 2013-01-14++ * Initial design+ * Blink example operational+ * Created home page at: http://leventerkok.github.com/hArduino 

@@ -1,9 +1,4 @@-The usbArduino library can be installed simply by issuing cabal install+The hArduino library can be installed simply by issuing cabal install like this: -     cabal install sbv--The package depends on the usb library itself, which in turn relies on-the availability of the libusb package on your platform. See notes-at https://github.com/basvandijk/bindings-libusb for details on how-to get the latter.+     cabal install hArduino

@@ -1,1 +0,0 @@-Please see http://leventerkok.github.com/hArduino.

@@ -0,0 +1,1 @@+Please see http://leventerkok.github.com/hArduino.

@@ -1,18 +0,0 @@-Hackage: http://hackage.haskell.org/package/hArduino-GitHub:  http://leventerkok.github.com/hArduino --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-- - Initial design- - Blink example operational- - Home page at: http://leventerkok.github.com/hArduino 

@@ -17,6 +17,9 @@ -- Arduino! It simply allows you to control a board from Haskell, where you -- can exchange information with the board, send/receive commands from other -- peripherals connected, etc.+--+-- See <http://www.youtube.com/watch?v=PPa3im44t2g> for a short video (4m29s)+-- of the blink example. ------------------------------------------------------------------------------- module System.Hardware.Arduino (   -- * Running the controller@@ -24,15 +27,20 @@   -- * Programming the Arduino   -- ** Basic handshake with the board   , queryFirmware-  -- ** Controlling the pins-  , setPinMode-  -- ** Reading and Writing digital values-  , digitalRead, digitalWrite-  -- ** Misc utilities-  , waitFor, delay-  -- * Hardware components on the board-  -- ** Pins-  , pin, PinMode(..)+  -- ** Accessing pins+  , pin, Pin, PinMode(..), setPinMode+  -- ** Digital I/O+  -- *** Writing digital values+  , digitalWrite+  -- *** Reading digital values+  , digitalRead,  pullUpResistor, waitFor, waitAny, waitAnyHigh, waitAnyLow+  -- ** Analog Communication+  -- *** Setting up sampling interval+  , setAnalogSamplingInterval+  -- *** Reading analog values+  , analogRead+  -- * Misc utilities+  , delay  )  where 

@@ -9,18 +9,23 @@ -- Basic serial communication routines ------------------------------------------------------------------------------- -{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE NamedFieldPuns      #-}+{-# LANGUAGE ScopedTypeVariables #-} module System.Hardware.Arduino.Comm where  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.Concurrent   (MVar, myThreadId, ThreadId, throwTo, 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.Bits            (testBit, (.&.))+import Data.List            (intercalate)+import Data.Maybe           (listToMaybe) import System.Posix.Signals (installHandler, keyboardSignal, Handler(Catch))+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)+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) @@ -49,31 +54,51 @@            _ <- installHandler keyboardSignal (Catch (throwTo tid UserInterrupt)) Nothing            debugger <- mkDebugPrinter verbose            debugger $ "Accessing arduino located at: " ++ show fp-           let Arduino controller = do initialize+           listenerTid <- newEmptyMVar+           let Arduino controller = do initOK <- initialize listenerTid+                                       if initOK+                                          then program+                                          else error "Communication time-out (5s) expired."                                        program-           S.withSerial fp S.defaultSerialSettings{S.commSpeed = S.CS57600} $ \port -> do+           handle (\(e::SomeException) -> do cleanUp listenerTid+                                             hPutStrLn stderr $ "*** hArduino:ERROR: " ++ show e+                                                              ++ concatMap ("\n*** " ++) [ "Make sure your Arduino is connected to " ++ fp+                                                                                         , "And StandardFirmata is running on it!"+                                                                                         ]) $+             S.withSerial fp S.defaultSerialSettings{S.commSpeed = S.CS57600} $ \port -> do                 let initBoardState = BoardState {-                                         analogReportingPins  = S.empty+                                         boardCapabilities    = BoardCapabilities M.empty+                                       , analogReportingPins  = S.empty                                        , digitalReportingPins = S.empty                                        , pinStates            = M.empty                                        , digitalWakeUpQueue   = []+                                       , lcds                 = M.empty                                      }                 bs <- newMVar initBoardState                 dc <- newChan                 let initState = ArduinoState {                                    message       = debugger+                                 , bailOut       = bailOut listenerTid                                  , port          = port                                  , firmataID     = "Unknown"                                  , capabilities  = BoardCapabilities M.empty                                  , boardState    = bs                                  , deviceChannel = dc+                                 , listenerTid   = listenerTid                               }                 res <- tryJust catchCtrlC $ runStateT controller initState                 case res of                   Left () -> putStrLn "hArduino: Caught Ctrl-C, quitting.."                   _       -> return ()+                cleanUp listenerTid  where catchCtrlC UserInterrupt = Just ()        catchCtrlC _             = Nothing+       cleanUp tid = do mbltid <- tryTakeMVar tid+                        case mbltid of+                          Just t -> killThread t+                          _      -> return ()+       bailOut tid m ms = do cleanUp tid+                             error $ "\n*** hArduino:ERROR: " ++ intercalate "\n*** " (m:ms)  -- | Send down a request. send :: Request -> Arduino ()@@ -90,10 +115,14 @@ recv = do ch <- gets deviceChannel           liftIO $ readChan 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 received+recvTimeOut :: Int -> Arduino (Maybe Response)+recvTimeOut n = do ch <- gets deviceChannel+                   liftIO $ timeout n (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 :: Arduino ThreadId setupListener = do         serial <- gets port         dbg    <- gets message@@ -118,7 +147,20 @@                            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]+                  AnalogMessage mp l h -> modifyMVar_ bs $ \bst ->+                                           do -- the mp is indexed at 0; need to find the mapping+                                              let BoardCapabilities caps = boardCapabilities bst+                                                  mbP = listToMaybe [mappedPin | (mappedPin, (Just mp', _)) <- M.assocs caps, pinNo mp == mp']+                                              case mbP of+                                                Nothing -> return bst -- Mapping hasn't happened yet+                                                Just p  -> do+                                                   let v = (128 * fromIntegral (h .&. 0x07) + fromIntegral (l .&. 0x7f)) :: Int+                                                   case pinValue `fmap` (p `M.lookup` pinStates bst) of+                                                     Just (Just (Right v'))+                                                       | abs (v - v') < 10  -> return () -- be quiet, otherwise prints too much+                                                     _                      -> dbg $ "Updating analog pin " ++ show p ++ " values with " ++ showByteList [l,h] ++ " (" ++ show v ++ ")"+                                                   return bst{ pinStates = M.insert p PinData{pinMode = ANALOG, pinValue = Just (Right v)} (pinStates bst) }+                  DigitalMessage p l h -> do dbg $ "Updating digital 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@@ -137,37 +179,55 @@         bs <- gets boardState         tid <- liftIO $ forkIO $ forever (listener bs)         debug $ "Started listener thread: " ++ show tid+        return tid --- | Initialize our board, get capabilities, etc-initialize :: Arduino ()-initialize = do-     -- Step 1: Set up the listener thread-     setupListener+-- | Initialize our board, get capabilities, etc. Returns True if initialization+-- went OK, False if not.+initialize :: MVar ThreadId -> Arduino Bool+initialize ltid = do+     -- Step 0: Set up the listener thread+     tid <- setupListener+     liftIO $ putMVar ltid tid+     -- Step 1: Send a reset to get things going+     send SystemReset      -- 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+     -- To accommodate for the case when standard-Firmata may not be running,+     -- we will time out after 10 seconds of waiting, which should be plenty+     mbTo <- handshake QueryFirmware (Just (5000000 :: Int))+                       (\r -> case r of {Firmware{} -> True; _ -> False})+                       (\(Firmware v1 v2 m) -> modify (\s -> s{firmataID = "Firmware v" ++ show v1 ++ "." ++ show v2 ++ "(" ++ m ++ ")"}))+     case mbTo of+       Nothing -> return False  -- timed out+       Just () -> do -- Step 3: Send a capabilities request+                     _ <- handshake CapabilityQuery Nothing+                                    (\r -> case r of {Capabilities{} -> True; _ -> False})+                                    (\(Capabilities c) -> modify (\s -> s{capabilities = c}))+                     -- Step 4: Send analog-mapping query+                     _ <- handshake AnalogMappingQuery Nothing+                                    (\r -> case r of {AnalogMapping{} -> True; _ -> False})+                                    (\(AnalogMapping as) -> do BoardCapabilities m <- gets capabilities+                                                               -- need to put capabilities to both outer and inner state+                                                               let caps = BoardCapabilities (M.mapWithKey (mapAnalog as) m)+                                                               modify (\s -> s{capabilities = caps})+                                                               bs <- gets boardState+                                                               liftIO $ modifyMVar_ bs $ \bst -> return bst{boardCapabilities = caps})+                     -- We're done, print capabilities in debug mode+                     caps <- gets capabilities+                     dbg <- gets message+                     liftIO $ dbg $ "Handshake complete. Board capabilities:\n" ++ show caps+                     return True+ where handshake msg mbTOut 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+           let wait = do mbResp <- case mbTOut of+                                     Nothing -> Just `fmap` recv+                                     Just n  -> recvTimeOut n+                         case mbResp of+                           Nothing   -> return Nothing+                           Just resp -> if isOK resp+                                        then Just `fmap` process resp+                                        else do liftIO $ dbg $ "Skipping unexpected response: " ++ show resp+                                                wait            wait        mapAnalog bs p c           | i < rl && m /= 0x7f

@@ -12,10 +12,11 @@ {-# LANGUAGE DeriveFunctor               #-} {-# LANGUAGE GeneralizedNewtypeDeriving  #-} {-# LANGUAGE NamedFieldPuns              #-}+{-# LANGUAGE RankNTypes                  #-} module System.Hardware.Arduino.Data where  import Control.Applicative        (Applicative)-import Control.Concurrent         (Chan, MVar, modifyMVar, modifyMVar_, readMVar)+import Control.Concurrent         (Chan, MVar, modifyMVar, modifyMVar_, withMVar, ThreadId) import Control.Monad.State        (StateT, MonadIO, MonadState, gets, liftIO) import Data.Bits                  ((.&.), (.|.), setBit) import Data.List                  (intercalate)@@ -71,13 +72,15 @@              deriving (Eq, Show, Enum)  -- | A request, as sent to Arduino-data Request = QueryFirmware                        -- ^ Query the Firmata version installed+data Request = SystemReset                          -- ^ Send system reset+             | 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+             | SamplingInterval   Word8 Word8       -- ^ Set the sampling interval              deriving Show  -- | A response, as returned from the Arduino@@ -85,6 +88,7 @@               | Capabilities BoardCapabilities       -- ^ Capabilities report               | AnalogMapping [Word8]                -- ^ Analog pin mappings               | DigitalMessage Port Word8 Word8      -- ^ Status of a port+              | AnalogMessage  Pin  Word8 Word8      -- ^ Status of an analog pin               | Unimplemented (Maybe String) [Word8] -- ^ Represents messages currently unsupported  instance Show Response where@@ -92,6 +96,7 @@   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 (Unimplemented mbc bs)  = "Unimplemeneted " ++ fromMaybe "" mbc ++ " " ++ showByteList bs  -- | Resolution, as referred to in http://firmata.org/wiki/Protocol#Capability_Query@@ -118,22 +123,54 @@                }                deriving Show +-- | LCD's connected to the board+newtype LCD = LCD Int+            deriving (Eq, Ord, Show)++-- | Hitachi LCD controller: See: <http://en.wikipedia.org/wiki/Hitachi_HD44780_LCD_controller>.+-- We model only the 4-bit variant, with RS and EN lines only. (The most common Arduino usage.)+-- The data sheet can be seen at: <http://lcd-linux.sourceforge.net/pdfdocs/hd44780.pdf>.+data LCDController = Hitachi44780 {+                       lcdRS       :: Pin  -- ^ Hitachi pin @ 4@: Register-select+                     , lcdEN       :: Pin  -- ^ Hitachi pin @ 6@: Enable+                     , lcdD4       :: Pin  -- ^ Hitachi pin @11@: Data line @4@+                     , lcdD5       :: Pin  -- ^ Hitachi pin @12@: Data line @5@+                     , lcdD6       :: Pin  -- ^ Hitachi pin @13@: Data line @6@+                     , lcdD7       :: Pin  -- ^ Hitachi pin @14@: Data line @7@+                     , lcdRows     :: Int  -- ^ Number of rows (typically 1 or 2, upto 4)+                     , lcdCols     :: Int  -- ^ Number of cols (typically 16 or 20, upto 40)+                     , dotMode5x10 :: Bool -- ^ Set to True if 5x10 dots are used+                     }+                     deriving Show++-- | State of the LCD, a mere 8-bit word for the Hitachi+data LCDData = LCDData {+                  lcdDisplayMode    :: Word8         -- ^ Display mode (left/right/scrolling etc.)+                , lcdDisplayControl :: Word8         -- ^ Display control (blink on/off, display on/off etc.)+                , lcdGlyphCount     :: Word8         -- ^ Count of custom created glyphs (typically at most 8)+                , lcdController     :: LCDController -- ^ Actual controller+                }+ -- | 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+                    boardCapabilities    :: BoardCapabilities  -- ^ Capabilities of the board+                  , 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+                  , lcds                 :: M.Map LCD LCDData  -- ^ LCD's attached to the board                   }  -- | State of the computation data ArduinoState = ArduinoState {-                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+                message       :: String -> IO ()                      -- ^ Current debugging routine+              , bailOut       :: forall a. String -> [String] -> IO a -- ^ Clean-up and quit with a hopefully informative message+              , port          :: SerialPort                           -- ^ Serial port we are communicating on+              , firmataID     :: String                               -- ^ The ID of the board (as identified by the Board itself)+              , boardState    :: MVar BoardState                      -- ^ Current state of the board+              , deviceChannel :: Chan Response                        -- ^ Incoming messages from the board+              , capabilities  :: BoardCapabilities                    -- ^ Capabilities of the board+              , listenerTid   :: MVar ThreadId                        -- ^ ThreadId of the listener               }  -- | The Arduino monad.@@ -145,6 +182,11 @@ debug s = do f <- gets message              liftIO $ f s +-- | Bailing out: print the given string on stdout and die+die :: String -> [String] -> Arduino a+die m ms = do f <- gets bailOut+              liftIO $ f m ms+ -- | Which modes does this pin support? getPinModes :: Pin -> Arduino [PinMode] getPinModes p = do@@ -157,11 +199,12 @@ 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+  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  -- | Given a pin, collect the digital value corresponding to the -- port it belongs to, where the new value of the current pin is given@@ -185,11 +228,7 @@          [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)}+         bst' = bst{pinStates = M.insert curPin PinData{pinMode = OUTPUT, pinValue = Just (Left newValue)}(pinStates bst)}      return (bst', (lsb, msb))  -- | Keep track of listeners on a digital message@@ -316,11 +355,42 @@             -> 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+        -- see if there was a mode already set for this pin+        bs  <- gets boardState+        mbOldMode <- liftIO $ withMVar bs $ \bst ->+                                case p `M.lookup` pinStates bst of+                                  Nothing -> return Nothing -- completely new, register+                                  Just pd -> return $ Just $ pinMode pd+        -- depending on old/new mode, determine what actions to take+        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 []  -- no mode change, nothing to do+                  | True    -> do liftIO registerNewMode+                                  remActs <- getRemovalActions p m'+                                  addActs <- getModeActions p m+                                  return $ remActs ++ addActs++-- | A mode was removed from this pin, update internal state and determine any necessary actions to remove it+getRemovalActions :: Pin -> PinMode -> Arduino [Request]+getRemovalActions p INPUT  = do -- This pin is no longer digital input         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+        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)]   -- no need for a digital report on this port anymore+                    bst'  = bst { digitalReportingPins = dPins }+                return (bst', acts)+getRemovalActions p ANALOG = do -- This pin is no longer analog+        bs <- gets boardState+        liftIO $ modifyMVar bs $ \bst -> do+                let aPins = analogReportingPins bst+                    acts  = [AnalogReport p False | p `S.member` aPins] -- no need for an analog report on this port anymore+                    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]  -- | Depending on a mode-set call, determine what further -- actions should be executed, such as enabling/disabling pin/port reporting@@ -349,4 +419,5 @@                                    , digitalReportingPins = dPins                                    }                     return (bst', acts1 ++ acts2)-getModeActions _ _    = return []+getModeActions _ OUTPUT = return []+getModeActions p m      = die ("hArduino: getModeActions: TBD: Unsupported mode: " ++ show m) ["On pin " ++ show p]

@@ -1,36 +0,0 @@----------------------------------------------------------------------------------- |--- Module      :  System.Hardware.Arduino.Examples.Blink--- Copyright   :  (c) Levent Erkok--- License     :  BSD3--- Maintainer  :  erkokl@gmail.com--- Stability   :  experimental------ The /hello world/ of the arduino world, blinking the led.----------------------------------------------------------------------------------module System.Hardware.Arduino.Examples.Blink where--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.--- The blinking will synchronize with the printing of a dot on stdout.------ Depending on your set-up, you will need to change the path to the--- USB board. If you have problems, try changing the first argument--- to 'True' in the call to 'withArduino', which will hopefully print--- 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 "."-                        digitalWrite led True-                        delay 1000-                        digitalWrite led False-                        delay 1000

@@ -1,49 +0,0 @@----------------------------------------------------------------------------------- |--- 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

@@ -6,11 +6,165 @@ -- Maintainer  :  erkokl@gmail.com -- Stability   :  experimental ----- The Firmata protocol, as implemented in Haskell.--- See: www.firmata.org+-- Implementation of the firmata protocol --------------------------------------------------------------------------------module System.Hardware.Arduino.Firmata-  (module System.Hardware.Arduino.Firmata.Basics)-  where -import System.Hardware.Arduino.Firmata.Basics+{-# LANGUAGE NamedFieldPuns #-}+module System.Hardware.Arduino.Firmata where++import Control.Concurrent  (newEmptyMVar, readMVar)+import Control.Monad       (when, unless, void)+import Control.Monad.Trans (liftIO)+import Data.Bits           ((.&.), shiftR)+import Data.Word           (Word8)++import System.Hardware.Arduino.Data+import System.Hardware.Arduino.Comm+import qualified System.Hardware.Arduino.Utils as U++-- | Retrieve the Firmata firmware version running on the Arduino. The first+-- component is the major, second is the minor. The final value is a human+-- readable identifier for the particular board.+queryFirmware :: Arduino (Word8, Word8, String)+queryFirmware = do+        send QueryFirmware+        r <- recv+        case r of+          Firmware v1 v2 m -> return (v1, v2, m)+          _                -> die "queryFirmware: Got unexpected response for query firmware call: " [show r]++-- | 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+setPinMode :: Pin -> PinMode -> Arduino ()+setPinMode p m = do+   extras <- registerPinMode p m+   send $ SetPinMode p m+   mapM_ send extras++-- | Set or clear a digital pin on the board+digitalWrite :: Pin -> Bool -> Arduino ()+digitalWrite p v = do+   -- first make sure we have this pin set as output+   pd <- getPinData p+   when (pinMode pd /= OUTPUT) $ 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"+                                       ]+   case pinValue pd of+     Just (Left b) | b == v -> return () -- no change, nothing to do+     _                      -> do (lsb, msb) <- computePortData p v+                                  send $ DigitalPortWrite (pinPort p) lsb msb++-- | Turn on/off internal pull-up resistor on an input pin+pullUpResistor :: Pin -> Bool -> Arduino ()+pullUpResistor p v = do+   -- first make sure we have this pin set as input+   pd <- getPinData p+   when (pinMode pd /= INPUT) $ die ("Invalid turnOnPullUpResistor call on pin " ++ show p)+                                      [ "The current mode for this pin is: " ++ show (pinMode pd)+                                      , "For turnOnPullUpResistor, it must be set to: " ++ show INPUT+                                      , "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) $ 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 = head `fmap` waitAny [p]++-- | Wait for a change in any of the given pins. Once a change is detected, all the new values are+-- returned. Similar to 'waitFor', but is useful when we are watching multiple digital inputs.+waitAny :: [Pin] -> Arduino [Bool]+waitAny ps = map snd `fmap` waitGeneric ps++-- | Wait for any of the given pins to go from low to high. If all of the pins are high to start+-- with, then we first wait for one of them to go low, and then wait for one of them to go back high.+-- Returns the new values.+waitAnyHigh :: [Pin] -> Arduino [Bool]+waitAnyHigh ps = do+   curVals <- mapM digitalRead ps+   when (and curVals) $ void $ waitAnyLow ps   -- all are H to start with, wait for at least one to go low+   vs <- waitGeneric ps  -- wait for some change+   if (False, True) `elem` vs+      then return $ map snd vs+      else waitAnyHigh ps++-- | Wait for any of the given pins to go from high to low. If all of the pins are low to start+-- with, then we first wait for one of them to go high, and then wait for one of them to go back low.+-- Returns the new values.+waitAnyLow :: [Pin] -> Arduino [Bool]+waitAnyLow ps = do+   curVals <- mapM digitalRead ps+   unless (or curVals) $ void $ waitAnyHigh ps   -- all are L to start with, wait for at least one to go high+   vs <- waitGeneric ps  -- wait for some change+   if (True, False) `elem` vs+      then return $ map snd vs+      else waitAnyLow ps++-- | A utility function, waits for any change on any given pin+-- and returns both old and new values. It's guaranteed that+-- at least one returned pair have differing values.+waitGeneric :: [Pin] -> Arduino [(Bool, Bool)]+waitGeneric ps = do+   curVals <- mapM digitalRead ps+   semaphore <- liftIO newEmptyMVar+   let wait = do digitalWakeUp semaphore+                 liftIO $ readMVar semaphore+                 newVals <- mapM digitalRead ps+                 if curVals == newVals+                    then wait+                    else return $ zip curVals newVals+   wait++-- | Read the value of a pin in analog mode; this is a non-blocking call, immediately+-- returning the last sampled value. It returns @0@ if the voltage on the pin+-- is 0V, and @1023@ if it is 5V, properly scaled. (See `setAnalogSamplingInterval` for+-- sampling frequency.)+analogRead :: Pin -> Arduino Int+analogRead p = do+   -- first make sure we have this pin set as analog+   pd <- getPinData p+   when (pinMode pd /= ANALOG) $ die ("Invalid analogRead call on pin " ++ show p)+                                     [ "The current mode for this pin is: " ++ show (pinMode pd)+                                     , "For analogRead, it must be set to: " ++ show ANALOG+                                     , "via a proper call to setPinMode"+                                     ]+   return $ case pinValue pd of+              Just (Right v) -> v+              _              -> 0 -- no (correctly-typed) value reported yet, default to False++-- | Set the analog sampling interval, in milliseconds. Arduino uses a default of 19ms to sample analog and I2C+-- signals, which is fine for many applications, but can be modified if needed. The argument+-- should be a number between @10@ and @16384@; @10@ being the minumum sampling interval supported by Arduino+-- and @16383@ being the largest value we can represent in 14 bits that this message can handle. (Note that+-- the largest value is just about @16@ seconds, which is plenty infrequent for all practical needs.)+setAnalogSamplingInterval :: Int -> Arduino ()+setAnalogSamplingInterval i+  | i < 10 || i > 16383+  = die ("hArduino: setAnalogSamplingInterval: Allowed interval is [10, 16383] ms, received: " ++ show i) []+  | True+  = send $ SamplingInterval (fromIntegral lsb) (fromIntegral msb)+  where lsb = i .&. 0x7f+        msb = (i `shiftR` 7) .&. 0x7f

@@ -1,93 +0,0 @@----------------------------------------------------------------------------------- |--- Module      :  System.Hardware.Arduino.Firmata.Basics--- Copyright   :  (c) Levent Erkok--- License     :  BSD3--- Maintainer  :  erkokl@gmail.com--- Stability   :  experimental------ Basic components of the firmata protocol----------------------------------------------------------------------------------{-# 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 System.Hardware.Arduino.Data-import System.Hardware.Arduino.Comm-import qualified System.Hardware.Arduino.Utils as U---- | Retrieve the Firmata firmware version running on the Arduino. The first--- component is the major, second is the minor. The final value is a human--- readable identifier for the particular board.-queryFirmware :: Arduino (Word8, Word8, String)-queryFirmware = do-        send QueryFirmware-        r <- recv-        case r of-          Firmware v1 v2 m -> return (v1, v2, m)-          _                -> error $ "queryFirmware: Got unexpected response for query firmware call: " ++ show r---- | 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-setPinMode :: Pin -> PinMode -> Arduino ()-setPinMode p m = do-   extras <- registerPinMode p m-   send $ SetPinMode p m-   mapM_ send extras---- | Set or clear a digital pin on the board-digitalWrite :: Pin -> Bool -> Arduino ()-digitalWrite p v = do-   -- 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

@@ -0,0 +1,432 @@+-------------------------------------------------------------------------------------------------+-- |+-- Module      :  System.Hardware.Arduino.LCD+-- Copyright   :  (c) Levent Erkok+-- License     :  BSD3+-- Maintainer  :  erkokl@gmail.com+-- Stability   :  experimental+--+-- LCD (Liquid Crystal Display) parts supported by hArduino. The Haskell code+-- below has partly been implemented following the Arduino LiquidCrystal project+-- source code: <http://code.google.com/p/arduino/source/browse/trunk/libraries/LiquidCrystal/>+--+-- The Hitachi44780 data sheet is at: <http://lcd-linux.sourceforge.net/pdfdocs/hd44780.pdf>+--+-- For an example program using this library, see "System.Hardware.Arduino.SamplePrograms.LCD".+-------------------------------------------------------------------------------------------------++{-# LANGUAGE NamedFieldPuns #-}+module System.Hardware.Arduino.LCD(+  -- * LCD types and registration+  LCDController(..), lcdRegister+  -- * Writing text on the LCD+  , lcdClear, lcdWrite+  -- * Moving the cursor+  , lcdHome, lcdSetCursor+  -- * Scrolling+  , lcdAutoScrollOn, lcdAutoScrollOff+  , lcdScrollDisplayLeft, lcdScrollDisplayRight+  -- * Display properties+  , lcdLeftToRight, lcdRightToLeft+  , lcdBlinkOn, lcdBlinkOff+  , lcdCursorOn, lcdCursorOff+  , lcdDisplayOn, lcdDisplayOff+  -- * Accessing internal symbols,+  , LCDSymbol, lcdInternalSymbol, lcdWriteSymbol+  -- Creating custom symbols+  , lcdCreateSymbol+  -- * Misc helpers+  , lcdFlash+  )  where++import Control.Concurrent  (modifyMVar, withMVar)+import Control.Monad       (when)+import Control.Monad.State (gets, liftIO)+import Data.Bits           (testBit, (.|.), (.&.), setBit, clearBit, shiftL, bit)+import Data.Char           (ord, isSpace)+import Data.Maybe          (fromMaybe)+import Data.Word           (Word8)++import qualified Data.Map as M++import System.Hardware.Arduino.Data+import System.Hardware.Arduino.Firmata++import qualified System.Hardware.Arduino.Utils as U++---------------------------------------------------------------------------------------+-- Low level interface, not available to the user+---------------------------------------------------------------------------------------++-- | Commands understood by Hitachi+data Cmd = LCD_INITIALIZE+         | LCD_INITIALIZE_END+         | LCD_FUNCTIONSET+         | LCD_DISPLAYCONTROL Word8+         | LCD_CLEARDISPLAY+         | LCD_ENTRYMODESET   Word8+         | LCD_RETURNHOME+         | LCD_SETDDRAMADDR   Word8+         | LCD_CURSORSHIFT    Word8+         | LCD_SETCGRAMADDR   Word8++-- | Convert a command to a data-word+getCmdVal :: LCDController -> Cmd -> Word8+getCmdVal Hitachi44780{lcdRows, dotMode5x10} = get+  where multiLine -- bit 3+          | lcdRows > 1 = 0x08 :: Word8+          | True        = 0x00 :: Word8+        dotMode   -- bit 2+          | dotMode5x10 = 0x04 :: Word8+          | True        = 0x00 :: Word8+        displayFunction = multiLine .|. dotMode+        get LCD_INITIALIZE         = 0x33+        get LCD_INITIALIZE_END     = 0x32+        get LCD_FUNCTIONSET        = 0x20 .|. displayFunction+        get (LCD_DISPLAYCONTROL w) = 0x08 .|. w+        get LCD_CLEARDISPLAY       = 0x01+        get (LCD_ENTRYMODESET w)   = 0x04 .|. w+        get LCD_RETURNHOME         = 0x02+        get (LCD_SETDDRAMADDR w)   = 0x80 .|. w+        get (LCD_CURSORSHIFT w)    = 0x10 .|. 0x08 .|. w   -- NB. LCD_DISPLAYMOVE (0x08) hard coded here+        get (LCD_SETCGRAMADDR w)   = 0x40 .|. w `shiftL` 3++-- | Initialize the LCD. Follows the data sheet <http://lcd-linux.sourceforge.net/pdfdocs/hd44780.pdf>,+-- page 46; figure 24.+initLCD :: LCD -> LCDController -> Arduino ()+initLCD lcd c@Hitachi44780{lcdRS, lcdEN, lcdD4, lcdD5, lcdD6, lcdD7} = do+    debug "Starting the LCD initialization sequence"+    mapM_ (`setPinMode` OUTPUT) [lcdRS, lcdEN, lcdD4, lcdD5, lcdD6, lcdD7]+    -- Wait for 50ms, data-sheet says at least 40ms for 2.7V version, so be safe+    delay 50+    sendCmd c LCD_INITIALIZE+    delay 5+    sendCmd c LCD_INITIALIZE_END+    sendCmd c LCD_FUNCTIONSET+    lcdCursorOff lcd+    lcdBlinkOff lcd+    lcdLeftToRight lcd+    lcdAutoScrollOff lcd+    lcdHome lcd+    lcdClear lcd+    lcdDisplayOn lcd++-- | Get the controller associated with the LCD+getController :: LCD -> Arduino LCDController+getController lcd = do+  bs  <- gets boardState+  err <- gets bailOut+  liftIO $ withMVar bs $ \bst -> case lcd `M.lookup` lcds bst of+                                   Nothing -> err ("hArduino: Cannot locate " ++ show lcd) []+                                   Just ld -> return $ lcdController ld++-- | Send a command to the LCD controller+sendCmd :: LCDController -> Cmd -> Arduino ()+sendCmd c = transmit False c . getCmdVal c++-- | Send 4-bit data to the LCD controller+sendData :: LCDController -> Word8 -> Arduino ()+sendData lcd n = do debug $ "Transmitting LCD data: " ++ U.showByte n+                    transmit True lcd n++-- | By controlling the enable-pin, indicate to the controller that+-- the data is ready for it to process.+pulseEnable :: LCDController -> Arduino ()+pulseEnable Hitachi44780{lcdEN} = do+  debug "Sending LCD pulseEnable"+  digitalWrite lcdEN False+  delay 1+  digitalWrite lcdEN True+  delay 1+  digitalWrite lcdEN False+  delay 1++-- | Transmit data down to the LCD+transmit :: Bool -> LCDController -> Word8 -> Arduino ()+transmit mode c@Hitachi44780{lcdRS, lcdEN, lcdD4, lcdD5, lcdD6, lcdD7} val = do+  digitalWrite lcdRS mode+  digitalWrite lcdEN False+  let [b7, b6, b5, b4, b3, b2, b1, b0] = [val `testBit` i | i <- [7, 6 .. 0]]+  -- Send down the first 4 bits+  digitalWrite lcdD4 b4+  digitalWrite lcdD5 b5+  digitalWrite lcdD6 b6+  digitalWrite lcdD7 b7+  pulseEnable c+  -- Send down the remaining batch+  digitalWrite lcdD4 b0+  digitalWrite lcdD5 b1+  digitalWrite lcdD6 b2+  digitalWrite lcdD7 b3+  pulseEnable c++-- | Helper function to simplify library programming, not exposed to the user.+withLCD :: LCD -> String -> (LCDController -> Arduino a) -> Arduino a+withLCD lcd what action = do+        debug what+        c <- getController lcd+        action c++---------------------------------------------------------------------------------------+-- High level interface, exposed to the user+---------------------------------------------------------------------------------------++-- | Register an LCD controller. When registration is complete, the LCD will be initialized so that:+--+--   * Set display ON (Use 'lcdDisplayOn' / 'lcdDisplayOff' to change.)+--+--   * Set cursor OFF (Use 'lcdCursorOn' / 'lcdCursorOff' to change.)+--+--   * Set blink OFF  (Use 'lcdBlinkOn' / 'lcdBlinkOff' to change.)+--+--   * Clear display (Use 'lcdClear' to clear, 'lcdWrite' to display text.)+--+--   * Set entry mode left to write (Use 'lcdLeftToRight' / 'lcdRightToLeft' to control.)+--+--   * Set autoscrolling OFF (Use 'lcdAutoScrollOff' / 'lcdAutoScrollOn' to control.)+--+--   * Put the cursor into home position (Use 'lcdSetCursor' or 'lcdHome' to move around.)+lcdRegister :: LCDController -> Arduino LCD+lcdRegister controller = do+  bs <- gets boardState+  lcd <- liftIO $ modifyMVar bs $ \bst -> do+                    let n = M.size $ lcds bst+                        ld = LCDData { lcdDisplayMode    = 0+                                     , lcdDisplayControl = 0+                                     , lcdGlyphCount     = 0+                                     , lcdController     = controller+                                     }+                    return (bst {lcds = M.insert (LCD n) ld (lcds bst)}, LCD n)+  case controller of+     Hitachi44780{} -> initLCD lcd controller+  return lcd++-- | Write a string on the LCD at the current cursor position+lcdWrite :: LCD -> String -> Arduino ()+lcdWrite lcd m = withLCD lcd ("Writing " ++ show m ++ " to LCD") $ \c -> mapM_ (sendData c) m'+   where m' = map (\ch -> fromIntegral (ord ch) .&. 0xFF) m++-- | Clear the LCD+lcdClear :: LCD -> Arduino ()+lcdClear lcd = withLCD lcd "Sending clearLCD" $ \c ->+                 do sendCmd c LCD_CLEARDISPLAY+                    delay 2 -- give some time to make sure LCD is really cleared++-- | Send the cursor to home position+lcdHome :: LCD -> Arduino ()+lcdHome lcd = withLCD lcd "Sending the cursor home" $ \c ->+                do sendCmd c LCD_RETURNHOME+                   delay 2++-- | Set the cursor location. The pair of arguments is the new column and row numbers+-- respectively:+--+--   * The first value is the column, the second is the row. (This is counter-intuitive, but+--     is in line with what the standard Arduino programmers do, so we follow the same convention.)+--+--   * Counting starts at 0 (both for column and row no)+--+--   * If the new location is out-of-bounds of your LCD, we will put it the cursor to the closest+--     possible location on the LCD.+lcdSetCursor :: LCD -> (Int, Int) -> Arduino ()+lcdSetCursor lcd (givenCol, givenRow) = withLCD lcd ("Sending the cursor to Row: " ++ show givenRow ++ " Col: " ++ show givenCol) set+  where set c@Hitachi44780{lcdRows, lcdCols} = sendCmd c (LCD_SETDDRAMADDR offset)+              where align :: Int -> Int -> Word8+                    align i m+                      | i < 0  = 0+                      | i >= m = fromIntegral $ m-1+                      | True   = fromIntegral i+                    col = align givenCol lcdCols+                    row = align givenRow lcdRows+                    -- The magic row-offsets come from various web sources+                    -- I don't follow the logic in these numbers, but it seems to work+                    rowOffsets = [(0, 0), (1, 0x40), (2, 0x14), (3, 0x54)]+                    offset = col + fromMaybe 0x54 (row `lookup` rowOffsets)++-- | Scroll the display to the left by 1 character. Project idea: Using a tilt sensor, scroll the contents of the display+-- left/right depending on the tilt. +lcdScrollDisplayLeft :: LCD -> Arduino ()+lcdScrollDisplayLeft lcd = withLCD lcd "Scrolling display to the left by 1" $ \c -> sendCmd c (LCD_CURSORSHIFT lcdMoveLeft)+  where lcdMoveLeft = 0x00++-- | Scroll the display to the right by 1 character+lcdScrollDisplayRight :: LCD -> Arduino ()+lcdScrollDisplayRight lcd = withLCD lcd "Scrolling display to the right by 1" $ \c -> sendCmd c (LCD_CURSORSHIFT lcdMoveRight)+  where lcdMoveRight = 0x04++-- | Display characteristics helper, set the new control/mode and send+-- appropriate commands if anything changed+updateDisplayData :: String -> (Word8 -> Word8, Word8 -> Word8) -> LCD -> Arduino ()+updateDisplayData what (f, g) lcd = do+   debug what+   bs  <- gets boardState+   err <- gets bailOut+   (  LCDData {lcdDisplayControl = oldC, lcdDisplayMode = oldM}+    , LCDData {lcdDisplayControl = newC, lcdDisplayMode = newM, lcdController = c})+        <- liftIO $ modifyMVar bs $ \bst ->+                       case lcd `M.lookup` lcds bst of+                         Nothing -> err ("hArduino: Cannot locate " ++ show lcd) []+                         Just ld@LCDData{lcdDisplayControl, lcdDisplayMode}+                            -> do let ld' = ld { lcdDisplayControl = f lcdDisplayControl+                                               , lcdDisplayMode    = g lcdDisplayMode+                                               }+                                  return (bst{lcds = M.insert lcd ld' (lcds bst)}, (ld, ld'))+   when (oldC /= newC) $ sendCmd c (LCD_DISPLAYCONTROL newC)+   when (oldM /= newM) $ sendCmd c (LCD_ENTRYMODESET   newM)++-- | Update the display control word+updateDisplayControl :: String -> (Word8 -> Word8) -> LCD -> Arduino ()+updateDisplayControl what f = updateDisplayData what (f, id)++-- | Update the display mode word+updateDisplayMode :: String -> (Word8 -> Word8) -> LCD -> Arduino ()+updateDisplayMode what g = updateDisplayData what (id, g)++-- | Various control masks for the Hitachi44780+data Hitachi44780Mask = LCD_BLINKON              -- ^ bit @0@ Controls whether cursor blinks+                      | LCD_CURSORON             -- ^ bit @1@ Controls whether cursor is on+                      | LCD_DISPLAYON            -- ^ bit @2@ Controls whether display is on+                      | LCD_ENTRYSHIFTINCREMENT  -- ^ bit @0@ Controls left/right scroll+                      | LCD_ENTRYLEFT            -- ^ bit @1@ Controls left/right entry mode++-- | Convert the mask value to the bit no+maskBit :: Hitachi44780Mask -> Int+maskBit LCD_BLINKON             = 0+maskBit LCD_CURSORON            = 1+maskBit LCD_DISPLAYON           = 2+maskBit LCD_ENTRYSHIFTINCREMENT = 0+maskBit LCD_ENTRYLEFT           = 1++-- | Clear by the mask+clearMask :: Hitachi44780Mask -> Word8 -> Word8+clearMask m w = w `clearBit` maskBit m++-- | Set by the mask+setMask :: Hitachi44780Mask -> Word8 -> Word8+setMask m w = w `setBit` maskBit m++-- | Do not blink the cursor+lcdBlinkOff :: LCD -> Arduino ()+lcdBlinkOff = updateDisplayControl "Turning blinking off" (clearMask LCD_BLINKON)++-- | Blink the cursor+lcdBlinkOn :: LCD -> Arduino ()+lcdBlinkOn = updateDisplayControl "Turning blinking on" (setMask LCD_BLINKON)++-- | Hide the cursor. Note that a blinking cursor cannot be hidden, you must first+-- turn off blinking.+lcdCursorOff :: LCD -> Arduino ()+lcdCursorOff = updateDisplayControl "Not showing the cursor" (clearMask LCD_CURSORON)++-- | Show the cursor+lcdCursorOn :: LCD -> Arduino ()+lcdCursorOn = updateDisplayControl "Showing the cursor" (setMask LCD_CURSORON)++-- | Turn the display off. Note that turning the display off does not mean you are+-- powering it down. It simply means that the characters will not be shown until+-- you turn it back on using 'lcdDisplayOn'. (Also, the contents will /not/ be+-- forgotten when you call this function.) Therefore, this function is useful+-- for temporarily hiding the display contents.+lcdDisplayOff :: LCD -> Arduino ()+lcdDisplayOff = updateDisplayControl "Turning display off" (clearMask LCD_DISPLAYON)++-- | Turn the display on+lcdDisplayOn :: LCD -> Arduino ()+lcdDisplayOn = updateDisplayControl "Turning display on" (setMask LCD_DISPLAYON)++-- | Set writing direction: Left to Right+lcdLeftToRight :: LCD -> Arduino ()+lcdLeftToRight = updateDisplayMode "Setting left-to-right entry mode" (setMask LCD_ENTRYLEFT)++-- | Set writing direction: Right to Left+lcdRightToLeft :: LCD -> Arduino ()+lcdRightToLeft = updateDisplayMode "Setting right-to-left entry mode" (clearMask LCD_ENTRYLEFT)++-- | Turn on auto-scrolling. In the context of the Hitachi44780 controller, this means that+-- each time a letter is added, all the text is moved one space to the left. This can be+-- confusing at first: It does /not/ mean that your strings will continuously scroll:+-- It just means that if you write a string whose length exceeds the column-count+-- of your LCD, then you'll see the tail-end of it. (Of course, this will create a scrolling+-- effect as the string is being printed character by character.)+--+-- Having said that, it is easy to program a scrolling string program: Simply write your string+-- by calling 'lcdWrite', and then use the 'lcdScrollDisplayLeft' and 'lcdScrollDisplayRight' functions+-- with appropriate delays to simulate the scrolling.+lcdAutoScrollOn :: LCD -> Arduino ()+lcdAutoScrollOn = updateDisplayMode "Setting auto-scroll ON" (setMask LCD_ENTRYSHIFTINCREMENT)++-- | Turn off auto-scrolling. See the comments for 'lcdAutoScrollOn' for details. When turned+-- off (which is the default), you will /not/ see the characters at the end of your strings that+-- do not fit into the display.+lcdAutoScrollOff :: LCD -> Arduino ()+lcdAutoScrollOff = updateDisplayMode "Setting auto-scroll OFF" (clearMask LCD_ENTRYSHIFTINCREMENT)++-- | Flash contents of the LCD screen+lcdFlash :: LCD+         -> Int  -- ^ Flash count+         -> Int  -- ^ Delay amount (in milli-seconds)+         -> Arduino ()+lcdFlash lcd n d = sequence_ $ concat $ replicate n [lcdDisplayOff lcd, delay d, lcdDisplayOn lcd, delay d]++-- | An abstract symbol type for user created symbols+newtype LCDSymbol = LCDSymbol Word8++-- | Create a custom symbol for later display. Note that controllers+-- have limited capability for such symbols, typically storing no more+-- than 8. The behavior is undefined if you create more symbols than your+-- LCD can handle.+--+-- The input is a simple description of the glyph, as a list of precisely 8+-- strings, each of which must have 5 characters. Any space character is+-- interpreted as a empty pixel, any non-space is a full pixel, corresponding+-- to the pixel in the 5x8 characters we have on the LCD.  For instance, here's+-- a happy-face glyph you can use:+--+-- >+-- >   [ "     "+-- >   , "@   @"+-- >   , "     "+-- >   , "     "+-- >   , "@   @"+-- >   , " @@@ "+-- >   , "     "+-- >   , "     "+-- >   ]+-- >+lcdCreateSymbol :: LCD -> [String] -> Arduino LCDSymbol+lcdCreateSymbol lcd glyph+  | length glyph /= 8 || any (/= 5) (map length glyph)+  = die "hArduino: lcdCreateSymbol: Invalid glyph description: must be 8x5!" ("Received:" : glyph)+  | True+  = do bs  <- gets boardState+       err <- gets bailOut+       (i, c) <- liftIO $ modifyMVar bs $ \bst ->+                    case lcd `M.lookup` lcds bst of+                      Nothing -> err ("hArduino: Cannot locate " ++ show lcd) []+                      Just ld@LCDData{lcdGlyphCount, lcdController}+                              -> do let ld' = ld { lcdGlyphCount = lcdGlyphCount + 1 }+                                    return (bst{lcds = M.insert lcd ld' (lcds bst)}, (lcdGlyphCount, lcdController))+       sendCmd c (LCD_SETCGRAMADDR i)+       let cvt :: String -> Word8+           cvt s = foldr (.|.) 0 [bit p | (ch, p) <- zip (reverse s) [0..], not (isSpace ch)]+       mapM_ (sendData c . cvt) glyph+       return $ LCDSymbol i++-- | Display a user created symbol on the LCD. (See 'lcdCreateSymbol' for details.)+lcdWriteSymbol :: LCD -> LCDSymbol -> Arduino ()+lcdWriteSymbol lcd (LCDSymbol i) = withLCD lcd ("Writing custom symbol " ++ show i ++ " to LCD") $ \c -> sendData c i++-- | Access an internally stored symbol, one that is not available via its ASCII equivalent. See+-- the Hitachi datasheet for possible values: <http://lcd-linux.sourceforge.net/pdfdocs/hd44780.pdf>, Table 4 on page 17.+--+-- For instance, to access the symbol right-arrow:+--+--   * Locate it in the above table: Right-arrow is at the second-to-last row, 7th character from left.+--+--   * Check the upper/higher bits as specified in the table: For Right-arrow, upper bits are @0111@ and the+--     lower bits are @1110@; which gives us the code @01111110@, or @0x7E@.+--+--   * So, right-arrow can be accessed by symbol code 'lcdInternalSymbol' @0x7E@, which will give us a 'LCDSymbol' value+--   that can be passed to the 'lcdWriteSymbol' function. The code would look like this: @lcdWriteSymbol lcd (lcdInternalSymbol 0x7E)@.+lcdInternalSymbol :: Word8 -> LCDSymbol+lcdInternalSymbol = LCDSymbol

@@ -33,6 +33,7 @@ -- | Package a request as a sequence of bytes to be sent to the board -- using the Firmata protocol. package :: Request -> B.ByteString+package SystemReset              = nonSysEx SYSTEM_RESET            [] package QueryFirmware            = sysEx    REPORT_FIRMWARE         [] package CapabilityQuery          = sysEx    CAPABILITY_QUERY        [] package AnalogMappingQuery       = sysEx    ANALOG_MAPPING_QUERY    []@@ -40,6 +41,7 @@ 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]+package (SamplingInterval l m)   = sysEx    SAMPLING_INTERVAL       [l, m]  -- | Unpackage a SysEx response unpackageSysEx :: [Word8] -> Response@@ -67,12 +69,14 @@ 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 (ANALOG_MESSAGE       p)    = getBytes 2 >>= \[l, h] -> return (AnalogMessage  p l h)        grab (DIGITAL_MESSAGE      p)    = getBytes 2 >>= \[l, h] -> return (DigitalMessage p l h)+       -- we should never see any of the following since they are "request" codes+       -- TBD: Maybe we should put them in a different data-type        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 START_SYSEX                 = unimplemented 0        grab SET_PIN_MODE                = unimplemented 2-       grab END_SYSEX                   = unimplemented 0   -- we should never see this+       grab END_SYSEX                   = unimplemented 0        grab PROTOCOL_VERSION            = unimplemented 2        grab SYSTEM_RESET                = unimplemented 0

@@ -0,0 +1,43 @@+-------------------------------------------------------------------------------+-- |+-- Module      :  System.Hardware.Arduino.SamplePrograms.Analog+-- Copyright   :  (c) Levent Erkok+-- License     :  BSD3+-- Maintainer  :  erkokl@gmail.com+-- Stability   :  experimental+--+-- Reads the value of an analog input, controlled by a 10K potentiometer.+-------------------------------------------------------------------------------++module System.Hardware.Arduino.SamplePrograms.Analog where++import Control.Monad       (when)+import Control.Monad.Trans (liftIO)++import System.Hardware.Arduino++-- | Read the value of an analog input line. We will print the value+-- on the screen, and also blink a led on the Arduino based on the+-- value. The smaller the value, the faster the blink.+--+-- The circuit simply has a 10K potentiometer between 5V and GND, with+-- the wiper line connected to analog input 3. We also have a led between+-- pin 13 and GND.+--+--  <<http://github.com/LeventErkok/hArduino/raw/master/System/Hardware/Arduino/SamplePrograms/Schematics/Analog.png>>+analogVal :: IO ()+analogVal = withArduino False "/dev/cu.usbmodemfd131" $ do+               setPinMode led OUTPUT+               setPinMode pot ANALOG+               cur <- analogRead pot+               liftIO $ print cur+               go cur+  where led = pin 13+        pot = pin 17 -- NB. Analog-3 is pin 17 on the UNO+        go cur = do digitalWrite led True+                    delay cur+                    digitalWrite led False+                    delay cur+                    new <- analogRead pot+                    when (cur /= new) $ liftIO $ print new+                    go new

@@ -0,0 +1,33 @@+-------------------------------------------------------------------------------+-- |+-- Module      :  System.Hardware.Arduino.SamplePrograms.Blink+-- Copyright   :  (c) Levent Erkok+-- License     :  BSD3+-- Maintainer  :  erkokl@gmail.com+-- Stability   :  experimental+--+-- The /hello world/ of the arduino world, blinking the led.+-------------------------------------------------------------------------------++module System.Hardware.Arduino.SamplePrograms.Blink where++import Control.Monad       (forever)++import System.Hardware.Arduino++-- | Blink the led connected to port 13 on the Arduino UNO board.+--+-- Note that you do not need any other components to run this example: Just hook+-- up your Arduino to the computer and make sure StandardFirmata is running on it.+-- However, you can connect a LED between Pin13 and GND if you want to blink an+-- external led as well, as depicted below:+--+--  <<http://github.com/LeventErkok/hArduino/raw/master/System/Hardware/Arduino/SamplePrograms/Schematics/Blink.png>>+blink :: IO ()+blink = withArduino False "/dev/cu.usbmodemfd131" $ do+           let led = pin 13+           setPinMode led OUTPUT+           forever $ do digitalWrite led True+                        delay 1000+                        digitalWrite led False+                        delay 1000

@@ -0,0 +1,38 @@+-------------------------------------------------------------------------------+-- |+-- Module      :  System.Hardware.Arduino.SamplePrograms.Button+-- Copyright   :  (c) Levent Erkok+-- License     :  BSD3+-- Maintainer  :  erkokl@gmail.com+-- Stability   :  experimental+--+-- Reads the value of a push-button and displays it's status continuously+-- on the computer screen and by lighting a led on the Arduino as long as+-- the button is pressed.+-------------------------------------------------------------------------------++module System.Hardware.Arduino.SamplePrograms.Button where++import Control.Monad.Trans (liftIO)++import System.Hardware.Arduino++-- | Read the value of a push-button (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 13 on when the switch is pressed.+--+-- The wiring is straightforward: Simply put a push-button between+-- digital input 2 and +5V, guarded by a 10K resistor:+--+--  <<http://github.com/LeventErkok/hArduino/raw/master/System/Hardware/Arduino/SamplePrograms/Schematics/Button.png>>+button :: IO ()+button = withArduino False "/dev/cu.usbmodemfd131" $ do+            setPinMode led OUTPUT+            setPinMode pb  INPUT+            go =<< digitalRead pb+ where pb   = pin 2+       led  = pin 13+       go s = do liftIO $ putStrLn $ "Button is currently " ++ if s then "ON" else "OFF"+                 digitalWrite led s+                 go =<< waitFor pb

@@ -0,0 +1,46 @@+-------------------------------------------------------------------------------+-- |+-- Module      :  System.Hardware.Arduino.SamplePrograms.Counter+-- Copyright   :  (c) Levent Erkok+-- License     :  BSD3+-- Maintainer  :  erkokl@gmail.com+-- Stability   :  experimental+--+-- Demonstrates using two push-buttons to count up and down.+-------------------------------------------------------------------------------++module System.Hardware.Arduino.SamplePrograms.Counter where++import Control.Monad.Trans (liftIO)++import System.Hardware.Arduino++-- | Two push-button switches, controlling a counter value. We will increment+-- the counter if the first one ('bUp') is pressed, and decrement the value if the+-- second one ('bDown') is pressed. We also have a led connected to pin 13 (either use+-- the internal or connect an external one), that we light up when the counter value+-- is 0.+--+-- Wiring is very simple: Up-button connected to pin 4, Down-button connected+-- to pin 2, and a led on pin 13.+--+--  <<http://github.com/LeventErkok/hArduino/raw/master/System/Hardware/Arduino/SamplePrograms/Schematics/Counter.png>>+counter :: IO ()+counter = withArduino False "/dev/cu.usbmodemfd131" $ do+            setPinMode led   OUTPUT+            setPinMode bUp   INPUT+            setPinMode bDown INPUT+            update (0::Int)+ where bUp   = pin 4+       bDown = pin 2+       led   = pin 13+       update curVal = do+                liftIO $ print curVal+                digitalWrite led (curVal == 0)+                [up, down] <- waitAnyHigh [bUp, bDown]+                let newVal = case (up, down) of+                               (True,  True)  -> curVal    -- simultaneous press+                               (True,  False) -> curVal+1+                               (False, True)  -> curVal-1+                               (False, False) -> curVal    -- can't happen+                update newVal

@@ -0,0 +1,166 @@+-------------------------------------------------------------------------------+-- |+-- Module      :  System.Hardware.Arduino.SamplePrograms.LCD+-- Copyright   :  (c) Levent Erkok+-- License     :  BSD3+-- Maintainer  :  erkokl@gmail.com+-- Stability   :  experimental+--+-- Basic demo of an Hitachi HD44780 LCD+-------------------------------------------------------------------------------++module System.Hardware.Arduino.SamplePrograms.LCD where++import Control.Monad.Trans (liftIO)+import Data.Char           (isSpace)+import Numeric             (showHex)++import System.Hardware.Arduino+import System.Hardware.Arduino.LCD++-- | Connections for a basic hitachi controller.+-- See <http://en.wikipedia.org/wiki/Hitachi_HD44780_LCD_controller> for+-- pin layout. For this demo, simply connect the LCD pins to the Arduino+-- as follows:+--+--  * LCD pin @01@ to GND+--+--  * LCD pin @02@ to +5V+--+--  * LCD pin @03@ to a 10K potentiometer's viper+--+--  * LCD pin @04@ to Arduino pin @12@+--+--  * LCD pin @05@ to GND+--+--  * LCD pin @06@ to Arduino pin @11@+--+--  * LCD pin @11@ to Arduino pin @5@+--+--  * LCD pin @12@ to Arduino pin @4@+--+--  * LCD pin @13@ to Arduino pin @3@+--+--  * LCD pin @14@ to Arduino pin @2@+--+--  * [If backlight is needed] LCD pin @15@ to +5V+--+--  * [If backlight is needed] LCD pin @16@ to GND via 220ohm resistor+--+--  <<http://github.com/LeventErkok/hArduino/raw/master/System/Hardware/Arduino/SamplePrograms/Schematics/LCD.png>>+hitachi :: LCDController+-- Connections:                   ARDUINO     Hitachi   Description+--------------------------------  -------    ---------  ----------------+hitachi = Hitachi44780 { lcdRS   = pin 12  --     4      Register-select+                       , lcdEN   = pin 11  --     6      Enable+                       , lcdD4   = pin  5  --    11      Data 4+                       , lcdD5   = pin  4  --    12      Data 5+                       , lcdD6   = pin  3  --    13      Data 6+                       , lcdD7   = pin  2  --    14      Data 7+                       -- Other config variables for the display+                       , lcdRows     = 2    -- 2 rows+                       , lcdCols     = 16    -- of 16 columns+                       , dotMode5x10 = False -- Using the standard 5x8 dots+                       }++-- | The happy glyph. See 'lcdCreateSymbol' for details on how to create new ones.+happy :: [String]+happy = [ "     "+        , "@   @"+        , "     "+        , "     "+        , "@   @"+        , " @@@ "+        , "     "+        , "     "+        ]++-- | The sad glyph. See 'lcdCreateSymbol' for details on how to create new ones.+sad :: [String]+sad = [ "     "+      , "@   @"+      , "     "+      , "     "+      , "     "+      , " @@@ "+      , "@   @"+      , "     "+      ]++-- | Access the LCD connected to Arduino, making it show messages+-- we read from the user and demonstrate other LCD control features offered+-- by hArduino.+lcdDemo :: IO ()+lcdDemo = withArduino False "/dev/cu.usbmodemfd131" $ do+              lcd <- lcdRegister hitachi+              happySymbol <- lcdCreateSymbol lcd happy+              sadSymbol   <- lcdCreateSymbol lcd sad+              lcdHome lcd+              liftIO $ do putStrLn "Hitachi controller demo.."+                          putStrLn ""+                          putStrLn "Looking for an example? Try the following sequence:"+                          putStrLn "    cursor 5 0"+                          putStrLn "    happy"+                          putStrLn "    write _"+                          putStrLn "    happy"+                          putStrLn "    flash 5"+                          putStrLn ""+                          putStrLn "Type ? to see all available commands."+              let repl = do liftIO $ putStr "LCD> "+                            m <- liftIO getLine+                            case words m of+                              []       -> repl+                              ["quit"] -> return ()+                              (cmd:_)    -> case cmd `lookup` commands of+                                              Nothing        -> do liftIO $ putStrLn $ "Unknown command '" ++ cmd ++ "', type ? for help."+                                                                   repl+                                              Just (_, _, c) -> do c lcd (dropWhile isSpace (drop (length cmd) m)) (happySymbol, sadSymbol)+                                                                   repl+              repl+  where help = liftIO $ do let (cmds, args, hlps) = unzip3 $ ("quit", "", "Quit the demo") : [(c, a, h) | (c, (a, h, _)) <- commands]+                               clen = 1 + maximum (map length cmds)+                               alen = 8 + maximum (map length args)+                               pad l s = take l (s ++ repeat ' ')+                               line (c, a, h) = putStrLn $ pad clen c ++ pad alen a ++ h+                           mapM_ line $ zip3 cmds args hlps+        arg0 f _   [] _ = f+        arg0 _ _   a  _ = liftIO $ putStrLn $ "Unexpected arguments: " ++ show a+        arg1 f lcd [] _ = f lcd+        arg1 _ _   a  _ = liftIO $ putStrLn $ "Unexpected arguments: " ++ show a+        arg2 f lcd a  _ = f lcd a+        arg3            = id+        grabNums n a f  = case [v | [(v, "")] <- map reads (words a)] of+                            vs | length vs /= n -> liftIO $ putStrLn $ "Need " ++ show n ++ " numeric parameter" ++ if n == 1 then "." else "s."+                            vs                  -> f vs+        symbol isHappy lcd _ (h, s) = lcdWriteSymbol lcd (if isHappy then h else s)+        cursor lcd a = grabNums 2 a (\[col, row] -> lcdSetCursor lcd (col, row))+        flash  lcd a = grabNums 1 a (\[n] -> lcdFlash lcd n 500)+        code   lcd a = grabNums 1 a (\[n] -> do lcdClear lcd+                                                lcdHome lcd+                                                lcdWriteSymbol lcd (lcdInternalSymbol n)+                                                lcdWrite lcd $ " (Code: 0x" ++ showHex n "" ++ ")")+        scroll toLeft lcd a = grabNums 1 a (\[n] -> do let scr | toLeft = lcdScrollDisplayLeft+                                                               | True   = lcdScrollDisplayRight+                                                       sequence_ $ concat $ replicate n [scr lcd, delay 500])+        commands = [ ("?",           ("",        "Display this help message",   arg0 help))+                   , ("clear",       ("",        "Clear the LCD screen",        arg1 lcdClear))+                   , ("write",       ("string",  "Write to the LCD",            arg2 lcdWrite))+                   , ("home",        ("",        "Move cursor to home",         arg1 lcdHome))+                   , ("cursor",      ("col row", "Move cursor to col row",      arg2 cursor))+                   , ("scrollOff",   ("",        "Turn off auto-scroll",        arg1 lcdAutoScrollOff))+                   , ("scrollOn",    ("",        "Turn on auto-scroll",         arg1 lcdAutoScrollOn))+                   , ("scrollLeft",  ("n",       "Scroll left by n chars",      arg2 (scroll True)))+                   , ("scrollRight", ("n",       "Scroll right by n char",      arg2 (scroll False)))+                   , ("leftToRight", ("",        "Set left to right direction", arg1 lcdLeftToRight))+                   , ("rightToLeft", ("",        "Set left to right direction", arg1 lcdRightToLeft))+                   , ("blinkOn",     ("",        "Set blinking ON",             arg1 lcdBlinkOn))+                   , ("blinkOff",    ("",        "Set blinking ON",             arg1 lcdBlinkOff))+                   , ("cursorOn",    ("",        "Display the cursor",          arg1 lcdCursorOn))+                   , ("cursorOff",   ("",        "Do not display the cursor",   arg1 lcdCursorOff))+                   , ("displayOn",   ("",        "Turn the display on",         arg1 lcdDisplayOn))+                   , ("displayOff",  ("",        "Turn the display off",        arg1 lcdDisplayOff))+                   , ("flash",       ("n",       "Flash the display n times",   arg2 flash))+                   , ("happy",       ("",        "Draw a smiling face",         arg3 (symbol True)))+                   , ("sad",         ("",        "Draw a sad face",             arg3 (symbol False)))+                   , ("code",        ("n",       "Write symbol with code n",    arg2 code))+                   ]

@@ -60,10 +60,6 @@ -- | 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 [a]        = [chr (fromIntegral a)]  -- shouldn't happen 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)

@@ -1,5 +1,5 @@ Name:          hArduino-Version:       0.2+Version:       0.3 Category:      Hardware Synopsis:      Control your Arduino board from Haskell. Description:   Control Arduino from Haskell, using the Firmata protocol.@@ -11,6 +11,8 @@                can exchange information with the board, send/receive commands from other                peripherals connected, etc.                .+               A short (4m29s) video of the blinking example: <http://www.youtube.com/watch?v=PPa3im44t2g>+               .                hArduino is work-in-progress. Comments, bug-reports, and patches are welcome. Copyright:     Levent Erkok, 2013 License:       BSD3@@ -22,7 +24,7 @@ Maintainer:    Levent Erkok (erkokl@gmail.com) Build-Type:    Simple Cabal-Version: >= 1.14-Extra-Source-Files: INSTALL, README, COPYRIGHT, RELEASENOTES+Extra-Source-Files: INSTALL, README.md, COPYRIGHT, CHANGES.md  source-repository head     type:       git@@ -37,11 +39,14 @@                   -- 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+                  , System.Hardware.Arduino.LCD+                  , System.Hardware.Arduino.SamplePrograms.Analog+                  , System.Hardware.Arduino.SamplePrograms.Blink+                  , System.Hardware.Arduino.SamplePrograms.Button+                  , System.Hardware.Arduino.SamplePrograms.Counter+                  , System.Hardware.Arduino.SamplePrograms.LCD   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.Utils