path: root/src/Lazymail/Screen.hs

{- Lazymail interaction with curses.
 -
 - Copyright 2013 Raúl Benencia <rul@kalgan.cc>
 -
 - Licensed under the GNU GPL version 3 or higher
 -
 - This code is in an urgent need of a big refactoring.
 -}

module Lazymail.Screen where

import Codec.MIME.Type(MIMEValue(..))
import Control.Monad.Trans(liftIO)
import Control.Monad.Reader
import Control.Monad.State
import Data.Char(toUpper)
import Data.List(isPrefixOf)
import System.Exit
import UI.NCurses

-- Local imports
import Lazymail.Config
import qualified Lazymail.Handlers as EH
import Lazymail.Maildir
import Lazymail.Email(lookupField, getBody, getHeaders, lookupField')
import Lazymail.Print
import Codec.Text.Rfc1342
import Lazymail.State
import Lazymail.Types

{- This function is the nexus between Curses and IO -}
entryPoint :: Lazymail ()
entryPoint = do
  st <- get
  cfg <- ask
  maildirs <- liftIO $ do
    mds <- getMaildirsRecursively $ basePath st
    (filterMaildirsHook cfg) mds
  formattedMDs <- EH.formatMaildirModeRows st maildirs
  let mdState = (maildirState st) { detectedMDs = formattedMDs }
  liftIO $ runCurses $ runStateT (runReaderT startCurses cfg) (st { maildirState = mdState })
  return ()

{- Initial point of screen related functions. Get the number of rows,
 - colors, and start drawing the modes -}
startCurses :: LazymailCurses ()
startCurses = do
  st <- get
  cfg <- ask
  (=<<) put $ liftCurses $ do
    setEcho False
    setCursorMode CursorInvisible
    w <- defaultWindow
    (rows, cols) <- screenSize
    basColID <- newColorID (fst . baseColor $ cfg) (snd . baseColor $ cfg) 1
    selColID <- newColorID (fst . selectionColor $ cfg) (snd . selectionColor $ cfg) 2
    staColID <- newColorID (fst . statusBarColor $ cfg) (snd . statusBarColor $ cfg) 3
    heaColID <- newColorID (fst . headerColor $ cfg) (snd . headerColor $ cfg) 4
    newColID <- newColorID (fst . newEmailColor $ cfg) (snd . newEmailColor $ cfg) 5
    let style = ColorStyle basColID selColID staColID heaColID newColID
    return $ st { screenRows = fromIntegral $ rows - 1
                , screenColumns = fromIntegral $ cols
                , colorStyle = style }
  resetScrollBuffer
  screenLoop

{- This function will loop til the user decides to leave -}
screenLoop :: LazymailCurses ()
screenLoop = do
  w <- liftCurses $ defaultWindow
  cfg <- ask
  get >>=  \st ->
    (liftCurses . (updateWindow w) $ runStateT (runReaderT performUpdate cfg) st) >>= put . snd
  liftCurses $ render
  handleEvent
  get >>= \st -> if (not . exitRequested) st
                 then screenLoop
                 else return ()

{- Perform the screen update, by cleaning it first. -}
performUpdate :: LazymailUpdate LazymailState
performUpdate = do
  st <- get
  liftUpdate $ clearMain (scrRowsAsInteger st) (screenColumns st)
  drawMode (mode st)
  drawStatus
  get

{- Pattern match on the received mode and draw it in the screen. -}
drawMode :: Mode -> LazymailUpdate ()
drawMode MaildirMode = get >>= \st -> drawSelectionList $ scrollBufferMD . maildirState $ st
drawMode IndexMode   = get >>= \st -> drawSelectionList $ scrollBufferIn . indexState $ st
drawMode EmailMode   = drawEmailHelper

{- Draw a scrollable selection list -}
drawSelectionList [] = resetCurrentRow
drawSelectionList ((path, str):mds) = do
  st <- get
  (=<<) put $ liftUpdate $ do
    moveCursor (curRowAsInteger st) (colPadAsInteger st)
    if (selectedRow st == currentRow st)
      then do
        setColor $ selectionColorID . colorStyle $ st
        drawString $ normalizeLen (screenColumns st) str
        setColor $ baseColorID . colorStyle $ st
        case (mode st) of
          MaildirMode -> do
            let mst = (maildirState st) { selectedMD = path }
            return $ st { maildirState = mst }
          IndexMode   -> do
            let ist = (indexState st) { selectedEmailPath = path }
            return $ st { indexState = ist }
      else do
        drawSimpleRow st path str
        return st

  st <- get
  let limit = if statusBar st then (screenRows st) - 1 else screenRows st
  if currentRow st < limit
    then do
      incrementCurrentRow
      drawSelectionList mds
    else
      resetCurrentRow

drawSimpleRow st path str | (mode st) == MaildirMode = drawString $ normalizeLen (screenColumns st) str
                          | (mode st) == IndexMode   =
  if isNew path
  then do
    setColor $ newEmailColorID . colorStyle $ st
    drawCroppedString st str
    setColor $ baseColorID . colorStyle $ st
  else
    drawCroppedString st str

{- Empty the whole window. Useful when changing modes. -}
clearMain rows columns = do
  drawEmptyLine 0
  moveCursor 0 0
  where
    drawEmptyLine currentRow = do
      moveCursor currentRow 0
      drawString $ replicate (columns) ' '
      when (currentRow < rows - 1) $ drawEmptyLine $ currentRow + 1

{- Helper function of drawMode -}
drawEmailHelper = do
  drawEmailHeaders

  st <- get
  let est = emailState st
  put $ st { emailState = est { bodyStartRow = (currentRow st ) } }
  let body = getBody $ currentEmail . emailState $ st
  let maxRows = if statusBar st then (scrRowsAsInteger st) - 1 else scrRowsAsInteger st
  liftUpdate $
    drawBody (curRowAsInteger st) (colPadAsInteger st) maxRows $
      drop (scrollRowEm est) $ emailLines est
  resetCurrentRow

{- Draw the email headers -}
drawEmailHeaders = do
  st <- get
  cfg <- ask
  let hs = getHeaders $ currentEmail . emailState $ st
  let parsedHeaders = parseHeaders hs 0 $ headersToShow cfg

  liftUpdate $ do
    setColor $ headerColorID . colorStyle $ st
    drawHeaders st (curRowAsInteger st) parsedHeaders
    setColor $ baseColorID . colorStyle $ st
  put $ st { currentRow = 1 + (length parsedHeaders) + (currentRow st) }

  where
    parseHeaders _ _ [] = []
    parseHeaders headers row (h:hs)= do
      let field = lookupField' h headers
      case field of
        Nothing -> parseHeaders headers row hs
        Just f -> let p = capitalize h ++ ": " ++ (ppField f)
                  in p:parseHeaders headers (row + 1) hs

    capitalize str = (toUpper . head $ str):(tail str)
    drawHeaders _ _ []      = return ()
    drawHeaders st row (h:hs) = do
      moveCursor row (colPadAsInteger st)
      drawCroppedString st h
      drawHeaders st (row + 1) hs

{- Draw the email body -}
drawBody _ _ _ [] = return ()
drawBody row col maxRows (xs:xss) = do
  moveCursor row col
  drawString xs
  when (row <  maxRows) $ drawBody (row + 1) col maxRows  xss

{- Draw a status line with the current mode and other stuff -}
drawStatus  = do
  st <- get
  liftUpdate $ do
    moveCursor (scrRowsAsInteger st) 0
    setColor $ statusBarColorID . colorStyle $ st
    drawString $ normalizeLen (screenColumns st - 1)$ concat $ drawStatusHelper (mode st) st -- Can't write in the last char - ncurses bug
    setColor $ baseColorID . colorStyle $ st

{- Status bar string for Maildir mode -}
drawStatusHelper MaildirMode st =
  ["Maildir listing - "
  , "(", show ((selectedRow st) + (scrollRowMD . maildirState $ st) + 1), "/"
  ,  show (length $ detectedMDs . maildirState $ st), ")"]

{- Status bar string for Index mode -}
drawStatusHelper IndexMode st =
  ["mode: Index - "
  , "(", show ((selectedRow st) + (scrollRowIn . indexState $ st) + 1), "/"
  ,  show (currentInLen . indexState $ st), ")"]

{- Status bar string for Email mode -}
drawStatusHelper EmailMode st = ["mode: Email"]

{- Handle an event
 - TODO: Handle the events in a cleaner way. -}
handleEvent :: LazymailCurses ()
handleEvent = loop where
  loop = do
    w <- liftCurses $ defaultWindow
    ev <- liftCurses $ getEvent w Nothing
    st <- get
    case ev of
      Nothing  -> loop
      Just ev' ->
        case ev' of
          EventCharacter 'q'            -> EH.previousMode

          EventSpecialKey KeyUpArrow    -> EH.scrollUp
          EventCharacter 'k'            -> EH.scrollUp

          EventSpecialKey KeyDownArrow  -> EH.scrollDown
          EventCharacter 'j'            -> EH.scrollDown

          EventCharacter '\n'           -> EH.advanceMode
          EventSpecialKey KeyRightArrow -> EH.advanceMode

          _ ->  loop

{- Reset the current row to the beginning -}
resetCurrentRow = (=<<) put $ get >>= \st -> return $ st { currentRow = 0 }

{- Advance the current row. Useful when drawing modes -}
incrementCurrentRow = (=<<) put $ get >>= \st -> return $ st { currentRow = (currentRow st) + 1 }

{- Put the scroll at the top -}
resetScrollBuffer = do
  st <- get
  case (mode st) of
    MaildirMode -> do
      let mst = (maildirState st) {
            scrollBufferMD = EH.scrollCrop 0 (screenRows st) $ detectedMDs . maildirState $ st }
      put st { maildirState = mst}
    IndexMode -> do
      let ist = (indexState st) {
            scrollBufferIn = EH.formatIndexModeRows st $  EH.scrollCrop 0 (screenRows st) $ selectedEmails . indexState $ st }
      put st { indexState = ist }

drawCroppedString st str = drawString $ normalizeLen (screenColumns st) str

-- The type system complains if I want to use the same function for diferents monads
liftCurses = lift . lift
liftUpdate  = lift . lift