{-| Module : System.Hardware.PiLcd Description : Control an Adafruit character LCD and keypad kit Copyright : © Patrick Pelletier, 2017 License : BSD3 Maintainer : code@funwithsoftware.org Portability : Linux This module contains everything you need to use an from Haskell. The kit has a 16x2 character LCD, an RGB backlight which can produce 8 possible colors, and five buttons: Up, Down, Left, Right, and Select. Since the physical LCD+Keypad Kit is a global resource, only one 'PiLcd' should exist at a time. (Except in the very exceptional case where you have more than one LCD+Keypad Kit connected to your Raspberry Pi, at different addresses on the I²C bus.) If you create more than one 'PiLcd' at once when you only have one physical LCD+Keypad Kit, things will get very confused. Also, 'PiLcd' is not threadsafe, so if you want to use the 'PiLcd' from more than one thread, you will need to handle locking yourself. However, 'PiLcd' is safe in the presence of async exceptions. (In other words, 'updateDisplay' and other operations will either atomically occur or not occur; they will not be interrupted in the middle and leave the hardware in an inconsistent state.) -} module System.Hardware.PiLcd ( -- * Creating a PiLcd openPiLcd , closePiLcd , turnOffAndClosePiLcd , PiLcd , LcdAddress(..) , defaultLcdAddress , LcdOptions(..) , RomCode(..) , defaultLcdOptions -- * Backlight color -- | The kit lacks PWM, so each of the red, green, and blue LEDs can -- be either on or off, yielding 8 possible colors. , Color(..) , setBacklightColor -- * Buttons , Button(..) , ButtonDirection(..) , ButtonEvent(..) , getButtonEvent , getButtons -- ** Button bitmask values , buttonSelect , buttonRight , buttonDown , buttonUp , buttonLeft -- * Display -- | Displays Unicode text on the LCD. Only updates the parts -- of the LCD which have changed. Automatically manages -- custom characters, using the -- -- for characters which are not built-in to the the LCD controller's ROM. -- Only eight distinct non-built-in characters can be on the display -- at any one time. -- -- Only supports characters which are made up of a single code point. -- (In other words, combining marks are not supported.) If your input -- contains decomposed characters, consider using the -- -- package to convert to Normalization Form C. , updateDisplay , charFromAsciiArt , nativeChar -- * User Interface -- | Displays a simple user interface. The first line of the display -- is used as a \"list box\", where the user can scroll through a -- list of items one at a time using the up and down buttons. -- The second line of the display is used for virtual \"buttons\", -- such as \"OK\" and \"Cancel\". The user uses the left and right buttons -- to select a virtual \"button\". When the user presses the -- Select button, the interaction is considered done, and the calling -- program is given the list item and button selection that the user -- made. -- -- If there is only one item in the list, the up and down buttons won't -- do anything, and the \"↕\" indicator will not be displayed. So, if -- you want to display a static line of text and some buttons, just -- create a single-element list containing the line of text. , UiData(..) , UiState(..) , InternalState , defaultUiState , runUi , runUiUntilDone -- * Exception handling -- | These are specialized forms of 'bracket', where an uncaught -- exception causes the backlight to turn red and the exception to -- be displayed on the LCD. Then the exception is rethrown. This -- is useful for headless setups, where the LCD is the primary -- means of user interface. , withPiLcd , withPiLcdThenTurnOff ) where import Control.Concurrent import Control.DeepSeq import Control.Exception import Data.Bits import Data.IORef import qualified Data.Text as T import Data.Word import System.Hardware.PiLcd.Font5x8 import System.Hardware.PiLcd.Hd44780 import System.Hardware.PiLcd.I2c import System.Hardware.PiLcd.Mcp23017 import qualified System.Hardware.PiLcd.UnicodeLcd as U import System.Hardware.PiLcd.UnicodeLcd (LcdOptions(..), defaultLcdOptions, RomCode(..), nativeChar) import qualified System.Hardware.PiLcd.UserInterface as UI import System.Hardware.PiLcd.UserInterface (Button(..), ButtonDirection(..), ButtonEvent(..), UiData(..), UiState(..), InternalState, defaultUiState) import System.Hardware.PiLcd.Util -- | An opaque type representing an LCD and keypad kit. data PiLcd = PiLcd { plHandle :: !I2cHandle , plExpander :: !PortExpander , plButtons :: IORef Word8 , plCallbacks :: !LcdCallbacks , plLcd :: !U.Lcd } -- | Specifies how to connect to the LCD+Keypad Kit. 'laBus' should be 1 for -- revision 2 Raspberry Pis and later. For revision 1 Pis (those with 256 MB -- of RAM), the bus should be 0. If you need a way to automatically detect -- this, consider using the @piBoardRev@ function in the -- . -- On the other hand, there is not much reason to ever change -- 'laAddr' from the default 0x20. (The only reason would be if you changed -- the address of your LCD+Keypad Kit by messing with the address bit -- solder pads on the back. And probably the only reason you'd want to do -- that is to connect more than one LCD+Keypad Kit. That should work, in -- theory, but hasn't been tested.) data LcdAddress = LcdAddress { laBus :: Int -- ^ The I2C bus to communicate on , laAddr :: Int -- ^ The address on that bus to find the LCD+keypad kit } deriving (Eq, Ord, Show, Read) -- | Default values for 'LcdAddress'. Defaults to bus 1 and address 0x20. defaultLcdAddress :: LcdAddress defaultLcdAddress = LcdAddress { laBus = 1 , laAddr = 0x20 } -- | Colors for the LED backlight. If you have a single-color -- backlight, just use 'Off' and 'White' to turn it off and on. data Color = Off | Red | Green | Blue | Cyan | Magenta | Yellow | White deriving (Eq, Ord, Show, Read, Bounded, Enum) off, red, green, blue, cyan, magenta, yellow, white :: Word16 off = 0 red = bit 14 green = bit 15 blue = bit 0 cyan = green + blue magenta = red + blue yellow = red + green white = red + green + blue colorValue :: Color -> Word16 colorValue Off = off colorValue Red = red colorValue Green = green colorValue Blue = blue colorValue Cyan = cyan colorValue Magenta = magenta colorValue Yellow = yellow colorValue White = white buttonMaskA :: Word8 buttonMaskA = 0x1f buttonMask :: Word16 buttonMask = fromIntegral buttonMaskA `shiftL` 8 buttonList :: [Button] buttonList = [ButtonSelect, ButtonRight, ButtonDown, ButtonUp, ButtonLeft] bitSelect, bitRight, bitDown, bitUp, bitLeft :: Int bitSelect = 0 bitRight = 1 bitDown = 2 bitUp = 3 bitLeft = 4 buttonSelect, buttonRight, buttonDown, buttonUp, buttonLeft :: Word8 buttonSelect = bit bitSelect buttonRight = bit bitRight buttonDown = bit bitDown buttonUp = bit bitUp buttonLeft = bit bitLeft allBits :: Word16 allBits = 0xffff lcdBits :: Word16 lcdBits = 0x00fe -- rs, rw, e, db4-db7 -- | Opens the LCD+keypad kit, at the specified address, with the -- specified options. openPiLcd :: LcdAddress -> LcdOptions -> IO PiLcd openPiLcd la lo = do let lcdAddr = laAddr la h <- i2cOpen (laBus la) pe <- mkPortExpander (i2cReadReg h lcdAddr) (i2cWriteReg h lcdAddr) let outputs = white + lcdBits writeIoDir pe (complement outputs) allBits writeIPol pe 0 allBits writeGpPu pe buttonMask allBits writeGpio pe 0 lcdBits but <- newIORef 0 let cb = mkCallbacks pe lcdInitialize cb lcd <- U.mkLcd cb lo return $ PiLcd h pe but cb lcd -- | Returns all of the buttons which are currently depressed, as a -- bitwise \"or\" of 'buttonSelect', 'buttonRight', 'buttonDown', -- 'buttonUp', and 'buttonLeft'. getButtons :: PiLcd -> IO Word8 getButtons lcd = do x <- readGpioA (plExpander lcd) return $ (x .&. buttonMaskA) `xor` buttonMaskA findBit :: Word8 -> Int findBit b = f 0 where f n = if testBit b n then n else f (n + 1) -- | If a button has been pressed or released since the last call to -- 'getButtonEvent', returns information on that press or release as -- a 'ButtonEvent'. getButtonEvent :: PiLcd -> IO (Maybe ButtonEvent) getButtonEvent lcd = do newButs <- getButtons lcd oldButs <- readIORef (plButtons lcd) let changedButs = newButs `xor` oldButs if changedButs == 0 then return Nothing else do let aBit = findBit changedButs press = testBit newButs aBit x = oldButs `xor` bit aBit x `deepseq` writeIORef (plButtons lcd) x let dir = if press then Press else Release return $ Just $ ButtonEvent (buttonList !! aBit) dir -- | Set the LED backlight to one of the eight possible 'Color' values. -- If you have a single-color backlight, just use 'Off' and 'White' to -- turn it off and on. setBacklightColor :: PiLcd -> Color -> IO () setBacklightColor lcd c = writeGpio (plExpander lcd) (colorValue c `xor` white) white -- reverse the bits in a nibble reverseNibble :: Word8 -> Word8 reverseNibble x = -- https://graphics.stanford.edu/~seander/bithacks.html#ReverseParallel let x' = ((x `shiftR` 1) .&. 5) .|. ((x .&. 5) `shiftL` 1) in ((x' `shiftR` 2) .&. 3) .|. ((x' .&. 3) `shiftL` 2) mkByte :: LcdBus -> Word8 mkByte bus = bitIf (lbRS bus) 7 + -- RW (bit 6) is always 0, which means "write" bitIf (lbE bus) 5 + -- The data bus between the MCP23017 and the HD44780 is connected backwards! (reverseNibble (lbDB bus) `shiftL` 1) sendFunc :: PortExpander -> LcdBus -> IO () sendFunc pe bus = do let b = mkByte bus writeGpio pe (fromIntegral b) lcdBits mkCallbacks :: PortExpander -> LcdCallbacks mkCallbacks pe = LcdCallbacks { lcSend = sendFunc pe } -- | Update the display to contain the specified lines -- of text. This is done intelligently; i. e. only the -- characters which have changed are rewritten. -- The lines are truncated or padded with spaces to make -- them the width of the display. Similarly, the list -- of lines is truncated or padded with blank lines to -- make it the height of the display. updateDisplay :: PiLcd -> [T.Text] -> IO () updateDisplay lcd = U.updateDisplay (plLcd lcd) -- | Closes the 'PiLcd', leaving the display contents and -- backlight setting untouched. closePiLcd :: PiLcd -> IO () closePiLcd lcd = i2cClose (plHandle lcd) -- | Like 'closePiLcd', but clears the display, turns off the -- display, and turns off the backlight before closing the 'PiLcd'. turnOffAndClosePiLcd :: PiLcd -> IO () turnOffAndClosePiLcd lcd = do let cb = plCallbacks lcd lcdClear cb lcdControl cb False False False setBacklightColor lcd Off closePiLcd lcd -- | Updates the display based on the given UI state, and updates -- the UI state based on a button press or release which may have -- occurred since the last call. runUi :: PiLcd -> UiData -- ^ Data to display in the UI -> UiState -- ^ Current state of the interaction -> IO (UiState, Bool) -- ^ New UI state, and a flag indicating -- whether the interaction is done (i. e. user has -- pressed and released the \"Select\" button) runUi lcd dat st = do mbe <- getButtonEvent lcd let columns = loColumns $ U.lcdOptions $ plLcd lcd (ls, st', done) = UI.runUi dat st mbe columns updateDisplay lcd ls return (st', done) -- | Calls 'runUi' repeatedly, with a short delay in between, feeding back -- the state, until the interaction is \"done\". (i. e. user has -- pressed and released the \"Select\" button) The final state is -- returned, which indicates the selection the user has made. runUiUntilDone :: PiLcd -> UiData -- ^ Data to display in the UI -> UiState -- ^ Initial state (i. e. which list item and button -- start out highlighted) -> IO UiState -- ^ Final state (selections user made) runUiUntilDone lcd dat st = do (st', done) <- runUi lcd dat st if done then return st' else do threadDelay 20000 runUiUntilDone lcd dat st' -- | Opens a 'PiLcd' with the given 'LcdAddress' and 'LcdOptions', passes -- the 'PiLcd' to the body computation, and then closes the 'PiLcd', -- regardless of whether the body exited normally or exceptionally. -- If an exception occurred, the exception is shown on the LCD. withPiLcd :: LcdAddress -> LcdOptions -> (PiLcd -> IO a) -- ^ Body computation -> IO a -- ^ Result returned by body withPiLcd = withPiLcd' closePiLcd -- | Like 'withPiLcd', but in the non-exceptional case, the display is -- cleared and the backlight is turned off. withPiLcdThenTurnOff :: LcdAddress -> LcdOptions -> (PiLcd -> IO a) -- ^ Body computation -> IO a -- ^ Result returned by body withPiLcdThenTurnOff = withPiLcd' turnOffAndClosePiLcd wrapLine :: Int -> T.Text -> [T.Text] wrapLine columns txt | T.length txt <= columns = [txt] | otherwise = let (first, rest) = T.splitAt columns txt in first : wrapLine columns rest putExceptionOnLcd :: PiLcd -> SomeException -> IO () putExceptionOnLcd lcd se = do let columns = loColumns $ U.lcdOptions $ plLcd lcd rows = loLines $ U.lcdOptions $ plLcd lcd txt = padLine (columns * rows) $ T.pack $ show se txts = wrapLine columns txt setBacklightColor lcd Red updateDisplay lcd txts withPiLcd' :: (PiLcd -> IO ()) -> LcdAddress -> LcdOptions -> (PiLcd -> IO a) -> IO a withPiLcd' closeFunc la lo body = do lcd <- openPiLcd la lo eth <- try (body lcd) case eth of Left e -> do putExceptionOnLcd lcd e closePiLcd lcd throwIO e Right x -> do closeFunc lcd return x