{-# LANGUAGE
    ViewPatterns
  , NamedFieldPuns
  , DisambiguateRecordFields #-}
module Hardware.LCD.CFA635(
  -- * LCD devices
    LCD
  , withLCD
  , open
  , close

  -- * Display parameters
  , contrast
  , backlight
  , cursorStyle

  -- * Displaying text
  , clear
  , Pos(..)
  , move
  , write

  -- * Indicator LEDs
  , setLED
  , clearLEDs) where

import Data.Word
import Data.List
import Data.Bits
import Control.Monad
import Control.Monad.Maybe
import qualified System.Hardware.Serialport as Ser
import qualified Data.Digest.Table.CRC16    as CRC
import qualified Control.Exception          as Exn

clamp :: (Ord a) => String -> a -> a -> a -> a
clamp fun lb ub x
  | (x >= lb) && (x <= ub) = x
  | otherwise = error ("CFA635." ++ fun ++ ": argument out of bounds")

-- | Represents an open LCD device.  Abstract.
data LCD = LCD
  { lcdPort   :: Ser.SerialPort
  , lcdWidth  :: Int
  , lcdHeight :: Int }

data Pos = Pos Int Int
  deriving (Eq, Show)

pClamp :: String -> LCD -> Pos -> Pos
pClamp fun LCD{lcdWidth,lcdHeight}
  (Pos (clamp fun 0 (lcdWidth -1) -> col)
       (clamp fun 0 (lcdHeight-1) -> row)) = Pos col row

i8 :: Int -> Word8
i8 = fromIntegral

portSettings :: Ser.SerialPortSettings
portSettings = Ser.SerialPortSettings {
  baudRate    = Ser.B115200,
  bitsPerWord = 8,
  stopb       = Ser.One,
  parity      = Ser.NoParity,
  flowControl = Ser.NoFlowControl,
  timeout     = 1 } -- in sec / 10

-- | Open the LCD at a particular device file.
--   Maybe use @'withLCD'@ instead?
open :: FilePath -> IO LCD
open portName = do
  p <- Ser.openSerial portName portSettings
  let x = LCD p 20 4 -- hard-coded size of the CFA635
  clear     x
  clearLEDs x
  return    x

-- | Close the LCD file.  Maybe use @'withLCD'@ instead?
close :: LCD -> IO ()
close LCD{lcdPort} = Ser.closeSerial lcdPort

-- | Run an @'IO'@ action with a connection to an LCD.
withLCD :: FilePath -> (LCD -> IO a) -> IO a
withLCD f = Exn.bracket (open f) close

data Pkt = Pkt Word8 [Word8]
  deriving (Show)

-- | Clear the screen.
clear :: LCD -> IO ()
clear p = sendPkt p $ Pkt 0x06 []

-- | Set contrast. 0 is light, 254 is dark, 95 is recommended.
contrast :: LCD -> Int -> IO ()
contrast p (clamp "contrast" 0 254 -> x)
  = sendPkt p $ Pkt 0x0D [i8 x]

-- | Set backlight brightness. 0 is off, 100 is full on.
backlight :: LCD -> Int -> IO ()
backlight p (clamp "backlight" 0 100 -> x)
  = sendPkt p $ Pkt 0x0E [i8 x]

-- | Turn on or off an indicator LED.  Valid indices are from @[0..7]@.
setLED :: LCD -> Int -> Bool -> IO ()
setLED p (clamp "setLED" 0 7 -> i) st
  = sendPkt p $ Pkt 0x22 [i8 (5+i), if st then 100 else 0]

-- | Turn off all indicator LEDs.
clearLEDs :: LCD -> IO ()
clearLEDs p = forM_ [0..7] $ \i -> setLED p i False 

-- | Set the cursor style.  Valid styles are from @[0..4]@.
cursorStyle :: LCD -> Int -> IO ()
cursorStyle p (clamp "cursorStyle" 0 4 -> i) = sendPkt p $ Pkt 0x0C [i8 i]

encode :: String -> [Word8]
encode = map ec where
  ec x = case fromEnum x of
    i | i > 127   -> 187  -- 'dot' character for unencodable
      | otherwise -> fromIntegral i

-- | Write to the LCD at a specified position.
write :: LCD -> Pos -> String -> IO ()
write
    p@LCD{lcdWidth}
    (pClamp "write" p -> Pos col row)
    xs
  = sendPkt p $ Pkt 0x1F (i8 col : i8 row : encode pxs) where
      pxs = take (lcdWidth-col) xs

-- | Move the cursor.
move :: LCD -> Pos -> IO ()
move p (pClamp "write" p -> Pos col row)
  = sendPkt p $ Pkt 0x0B [i8 col, i8 row]

sendI :: (Integral a) => Ser.SerialPort -> a -> IO ()
sendI p = Ser.sendChar p . toEnum . fromIntegral

send8 :: Ser.SerialPort -> Word8 -> IO ()
send8 = sendI

send16 :: Ser.SerialPort -> Word16 -> IO ()
send16 p n = do
  sendI p (n .&. 0xFF)
  sendI p (n `shiftR` 8)

sendPkt1 :: LCD -> Pkt -> IO ()
sendPkt1 LCD{lcdPort=p} (Pkt ty dat) = do
  send8 p ty
  let lenb = genericLength dat
  send8 p lenb
  mapM_ (send8 p) dat
  send16 p $ CRC.crc16 (ty:lenb:dat)

sendPkt :: LCD -> Pkt -> IO ()
sendPkt l p = do
  sendPkt1 l p
  _ <- recvPkt l
  return ()

recv8 :: Ser.SerialPort -> IO (Maybe Word8)
recv8 = fmap (fmap (fromIntegral . fromEnum)) . Ser.recvChar

trecv16 :: Ser.SerialPort -> MaybeT IO Word16
trecv16 p = do
  l <- trecv8 p
  h <- trecv8 p
  return (fromIntegral l .|. (fromIntegral h `shiftL` 8))

trecv8 :: Ser.SerialPort -> MaybeT IO Word8
trecv8 = MaybeT . recv8

recvPkt :: LCD -> IO (Maybe Pkt)
recvPkt LCD{lcdPort=p} = runMaybeT $ do
  typ <- trecv8 p
  len <- trecv8 p
  dat <- replicateM (fromIntegral len) $ trecv8 p
  cs  <- trecv16 p
  when (CRC.crc16 (typ:len:dat) /= cs) $
    fail "bad crc"
  return (Pkt typ dat)