From 41b53ca04b6d52457f331930e8fea68416498882 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ra=C3=BAl=20Benencia?= Date: Thu, 5 Sep 2013 19:36:33 -0300 Subject: New project tree structure --- Lazymail/Screen.hs | 268 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 268 insertions(+) create mode 100644 Lazymail/Screen.hs (limited to 'Lazymail/Screen.hs') diff --git a/Lazymail/Screen.hs b/Lazymail/Screen.hs new file mode 100644 index 0000000..699f84e --- /dev/null +++ b/Lazymail/Screen.hs @@ -0,0 +1,268 @@ +{- Lazymail interaction with curses. + - + - Copyright 2013 Raúl Benencia + - + - 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 (mode st) + + EventSpecialKey KeyUpArrow -> EH.decSelectedRow (mode st) + EventCharacter 'k' -> EH.decSelectedRow (mode st) + + EventSpecialKey KeyDownArrow -> EH.incSelectedRow (mode st) + EventCharacter 'j' -> EH.incSelectedRow (mode st) + + EventCharacter '\n' -> EH.changeMode (mode st) + EventSpecialKey KeyRightArrow -> EH.changeMode (mode st) + + _ -> 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 -- cgit v1.2.3