diff options
Diffstat (limited to 'Screen.hs')
| -rw-r--r-- | Screen.hs | 217 |
1 files changed, 217 insertions, 0 deletions
diff --git a/Screen.hs b/Screen.hs new file mode 100644 index 0000000..fa01584 --- /dev/null +++ b/Screen.hs @@ -0,0 +1,217 @@ +-- This module is part of Lazymail, a Haskell email client. +-- +-- Copyright (C) 2013 Raúl Benencia <rul@kalgan.cc> +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program. If not, see <http://www.gnu.org/licenses/>. + +module Screen where + +import Data.List(isPrefixOf) +import UI.NCurses +import Text.ParserCombinators.Parsec.Rfc2822(Message(..)) + +-- Local imports +import Maildir +import Email +import Print +import Rfc1342 +import State + +ppBaseRow = 0 +ppBaseColumn = 0 + +-- +-- | Main entry point +-- +entryPoint :: MState -> IO () +entryPoint st' = do + maildirs <- getMaildirsRecursively (initPath st') + putStrLn $ "We could get " ++ (show . length) maildirs ++ " maildirs." + runCurses $ do + setEcho False + (rows, columns) <- screenSize + selColID <- newColorID ColorBlack ColorWhite 1 + let st = st' { + scrRows = rows - 1 + , scrColumns = columns - 1 + , selectedColorID = selColID + , detectedMDs = maildirs } + screenLoop st + +screenLoop :: MState -> Curses () +screenLoop st = do + w <- defaultWindow + updateWindow w $ do + clearMain (fromIntegral . scrRows $ st) (fromIntegral . scrColumns $ st) + drawMode (mode st) st + render + st' <- handleEvent st + if (not . exitRequested) st' + then screenLoop st' + else return () + +-- +-- | Handle an event +-- +handleEvent :: MState -> Curses MState +handleEvent st = loop where + loop = do + w <- defaultWindow + ev <- getEvent w Nothing + case ev of + Nothing -> loop + Just ev' -> case ev' of + EventCharacter c | c == 'q' || c == 'Q' -> return $ st { exitRequested = True } + EventSpecialKey KeyUpArrow -> return $ decSelectedRow st + EventCharacter 'k' -> return $ decSelectedRow st + + EventSpecialKey KeyDownArrow -> return $ incSelectedRow st + EventCharacter 'j' -> return $ incSelectedRow st + + _ -> loop + +-- +-- | Pattern match on the received mode and draw it in the screen. +-- +drawMode :: Mode -> MState -> Update () +drawMode MaildirMode st = drawMaildirHelper st (detectedMDs st) +drawMode EmailMode st = drawEmailHelper st +drawMode IndexMode st = drawIndexHelper 0 0 (curRow st) (colPadding st) (selectedEmails st) + +drawMaildirHelper _ [] = return () +drawMaildirHelper st (md:mds) = do + moveCursor (curRow st) (colPadding st) + if (selectedRow st == curRow st) + then do + setColor $ selectedColorID st + drawString $ normalizeLen (fromIntegral . scrColumns $ st) md + setColor defaultColorID + else drawString $ normalizeLen (fromIntegral . scrColumns $ st) md + if curRow st < scrRows st + then drawMaildirHelper (incCurRow st) mds + else return () + +drawIndexHelper origRow origColumn rows columns [] = moveCursor 0 0 +drawIndexHelper origRow origColumn rows columns ((fp, _, msg):ts) = do + moveCursor origRow origColumn + let fs = getFields $ parseEmail msg + drawString $ show $ origRow + 1 + drawString $ (ppSep ++) $ ppFlags . getFlags $ fp + drawString $ (ppSep ++) $ ppIndexNameAddr . getFrom $ fs + drawString $ (ppSep ++) $ ppIndexSubject . getSubject $ fs + if origRow < (rows - 1) + then drawIndexHelper (origRow + 1) origColumn rows columns ts + else return () + +waitFor :: Window -> (Event -> Bool) -> Curses () +waitFor w p = loop where + loop = do + ev <- getEvent w Nothing + case ev of + Nothing -> loop + Just ev' -> if p ev' then return () else loop + +extractParsedData :: Either a b -> b +extractParsedData (Right msg) = msg +--extractParsedData (Left err) = error err + +drawEmailHelper st = do + let fs = getFields $ selectedEmail st + let cropWith xs = normalizeLen $ (fromIntegral . scrColumns $ st) - (length xs) + let row = curRow st + moveCursor row (colPadding st) + drawString $ ("From: " ++) $ cropWith "From: " . ppNameAddr . getFrom $ fs + moveCursor (row + 1) (colPadding st) + drawString $ ("To: " ++) $ cropWith "To: " . ppNameAddr . getTo $ fs + moveCursor (row + 2) (colPadding st) + drawString $ ("Subject: " ++) $ cropWith "Subject: " . ppSubject . getSubject $ fs + + let body = getBody $ selectedEmail st + drawBody (row + 4) (colPadding st) $ formatBody body (fromIntegral . scrColumns $ st) + where drawBody _ _ [] = return () + drawBody row col (xs:xss) = do + moveCursor row col + drawString xs + if row < (scrRows st) then drawBody (row + 1) col xss else return () +-- +-- | Empty the whole window. Useful when changing modes. +-- +clearMain rows columns = do + drawEmptyLine 0 + where + drawEmptyLine currentRow = do + moveCursor currentRow 0 + drawString $ replicate (columns - 1) ' ' + if currentRow < (rows - 1) + then drawEmptyLine $ currentRow + 1 + else return () + +-- +-- | Convert a String to multiple Strings, cropped by the maximum column +-- | size if necessary. +-- +formatBody :: String -> Int -> [String] +formatBody body maxColumns = format [] [] body where + format parsed acc [] = parsed ++ [acc] + format parsed acc ('\r':'\n':xs) = format (parsed ++ [acc]) [] xs + format parsed acc rest@(x:xs) | length acc < maxColumns = format parsed (acc ++ [x]) xs + | otherwise = format (parsed ++ [acc]) "+" rest + + + +-- drawIndex :: Maildir -> IO () +-- drawIndex md = do +-- emails <- getAll md +-- runCurses $ do +-- setEcho False +-- (rows, columns) <- screenSize +-- w <- defaultWindow +-- updateWindow w $ do +-- clearMain (fromIntegral rows) (fromIntegral columns) +-- drawIndexHelper 0 0 (fromIntegral rows) (fromIntegral columns) emails +-- render +-- waitFor w (\ev -> ev == EventCharacter 'q' || ev == EventCharacter 'Q') +-- let (_, _, msg) = head emails +-- drawEmail $ parseEmail msg + +-- drawEmail :: Message -> IO () +-- drawEmail email = do +-- runCurses $ do +-- setEcho False +-- (rows, columns) <- screenSize +-- w <- defaultWindow +-- updateWindow w $ do +-- clearMain (fromIntegral rows) (fromIntegral columns) +-- drawEmailHelper ppBaseRow ppBaseColumn (fromIntegral rows - 1) (fromIntegral columns - 1) email +-- render +-- waitFor w (\ev -> ev == EventCharacter 'q' || ev == EventCharacter 'Q') + +-- drawMaildir :: MState -> IO () +-- drawMaildir st = do +-- maildirs <- getMaildirsRecursively (initPath st) +-- runCurses $ do +-- setEcho False +-- (rows, columns) <- screenSize +-- selColID <- newColorID ColorBlack ColorWhite 1 +-- let st' = st { +-- scrRows = rows - 1 +-- , scrColumns = columns - 1 +-- , selectedColorID = selColID } +-- w <- defaultWindow +-- updateWindow w $ do +-- clearMain (fromIntegral rows) (fromIntegral columns) +-- drawMaildirHelper st' maildirs +-- render +-- waitFor w (\ev -> ev == EventCharacter 'q' || ev == EventCharacter 'Q') +
\ No newline at end of file |