{-|
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
<https://www.adafruit.com/categories/808 Adafruit character LCD and keypad kit>
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
    -- <https://www.cl.cam.ac.uk/~mgk25/ucs-fonts.html 5x8 fixed font>
    -- 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
    -- <https://hackage.haskell.org/package/unicode-transforms unicode-transforms>
    -- 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
-- <https://hackage.haskell.org/package/wiringPi wiringPi package>.
-- 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