Skip to content

Commit

Permalink
More efficient List impl. based on Data.Sequence
Browse files Browse the repository at this point in the history 
Add module Qoropa.Widget.List
Move common list handling to this module to avoid code duplication
Use a Sequence instead of a List to represents lines
  • Loading branch information
@alip
alip committed Jun 13, 2010
1 parent 03913e6 commit 5d3d825
Show file tree
Hide file tree
Showing 6 changed files with 457 additions and 367 deletions.
2 changes: 2 additions & 0 deletions qoropa.cabal
View file
Original file line number Diff line number Diff line change
Expand Up @@ -16,6 +16,7 @@ library
hs-source-dirs: src

exposed-modules:
Qoropa.Widget.List
Qoropa.Buffer.Folder
Qoropa.Buffer.Log
Qoropa.Buffer.Search
Expand Down Expand Up @@ -45,6 +46,7 @@ executable qoropa
ghc-options: -Wall

other-modules:
Qoropa.Widget.List
Qoropa.Buffer.Folder
Qoropa.Buffer.Log
Qoropa.Buffer.Search
Expand Down
176 changes: 80 additions & 96 deletions src/Qoropa/Buffer/Folder.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -18,17 +18,18 @@
-}

module Qoropa.Buffer.Folder
( Attributes(..), Theme(..), Line(..), StatusBar(..), StatusMessage(..), Folder(..)
( Attributes(..), Theme(..), LineData(..), StatusBar(..), StatusMessage(..), Folder(..)
, emptyFolder
, paint, load, new
, scrollUp, scrollDown
, selectPrev, selectNext
, termSelected, cancelLoad
) where

import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, tryPutMVar, tryTakeMVar)
import Control.Monad (when, unless)
import Data.IORef (IORef, readIORef, writeIORef)
import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, tryPutMVar, tryTakeMVar)
import Control.Monad (when, unless)
import Data.IORef (IORef, readIORef, writeIORef)
import Data.Maybe (isJust, fromJust)

import Graphics.Vty
( Attr, Image, Picture
Expand All @@ -44,6 +45,16 @@ import qualified Email.Notmuch as NM
import Qoropa.Lock (Lock)
import qualified Qoropa.Lock as Lock (with)

import Qoropa.Widget.List
( Line(..), List(..)
, emptyList
, listLength, listIndex, listAppend
, listRender
, listScrollUp, listScrollDown
, listSelectPrev, listSelectNext
, toRegion
)

import {-# SOURCE #-} Qoropa.UI (UIEvent(..))

data Attributes = Attributes
Expand All @@ -58,8 +69,8 @@ data Attributes = Attributes

data Theme = Theme
{ themeAttrs :: Attributes
, themeFill :: String
, themeDrawLine :: Attributes -> Int -> Line -> Image
, themeFill :: Maybe String
, themeDrawLine :: Attributes -> LineData -> Bool -> Image
, themeDrawStatusBar :: Attributes -> StatusBar -> Image
, themeDrawStatusMessage :: Attributes -> StatusMessage -> Image
, themeFormatHitTheTop :: IO String
Expand All @@ -68,9 +79,8 @@ data Theme = Theme
, themeFormatLoadingDone :: (String, String) -> IO String
}

data Line = Line
{ lineIndex :: Int
, folderName :: String
data LineData = LineData
{ folderName :: String
, folderTerm :: String
, folderCount :: Integer
}
Expand All @@ -83,9 +93,7 @@ data StatusBar = StatusBar
data StatusMessage = StatusMessage { sMessage :: String }

data Folder = Folder
{ bufferFirst :: Int
, bufferSelected :: Int
, bufferLines :: [Line]
{ bufferList :: List LineData
, bufferStatusBar :: StatusBar
, bufferStatusMessage :: StatusMessage
, bufferTheme :: Theme
Expand All @@ -105,123 +113,97 @@ emptyFolder :: Theme -> IO Folder
emptyFolder theme = do
cancelFolder <- newEmptyMVar
return Folder
{ bufferFirst = 1
, bufferSelected = 1
, bufferLines = []
{ bufferList = emptyList { listLineFill = fill }
, bufferStatusBar = emptyStatusBar
, bufferStatusMessage = emptyStatusMessage
, bufferTheme = theme
, bufferCancel = cancelFolder
}
where
fill = if isJust (themeFill theme)
then Just (string (attrFill $ themeAttrs theme) (fromJust $ themeFill theme))
else Nothing

paint :: Folder -> Int -> Picture
paint buf height =
pic_for_image $ vert_cat $ lns ++ fill ++ [bar, msg]
pic_for_image $ vert_cat $ lns ++ [bar, msg]
where
myFirst = bufferFirst buf
mySelected = bufferSelected buf
myLines = bufferLines buf
myTheme = bufferTheme buf
myAttr = themeAttrs myTheme
myDrawLine = themeDrawLine myTheme
myDrawStatusBar = themeDrawStatusBar myTheme
myDrawStatusMessage = themeDrawStatusMessage myTheme

lns = take (height - 2) $ drop (myFirst - 1) $ map (myDrawLine myAttr mySelected) myLines

len = length lns
fill = if len < height - 2
then replicate (height - 2 - len) (string (attrFill myAttr) (themeFill myTheme))
else []

bar = myDrawStatusBar myAttr (bufferStatusBar buf)
msg = myDrawStatusMessage myAttr (bufferStatusMessage buf)
lns = listRender (bufferList buf) (toRegion (height - 2) 0)
bar = myDrawStatusBar myAttr (bufferStatusBar buf)
msg = myDrawStatusMessage myAttr (bufferStatusMessage buf)

scrollUp :: (IORef Folder, Lock) -> Int -> IO ()
scrollUp (ref, lock) count = Lock.with lock $ scrollUp' ref count
scrollUp (ref, lock) cnt = Lock.with lock $ scrollUp' ref cnt

scrollUp' :: IORef Folder -> Int -> IO ()
scrollUp' ref count = do
scrollUp' ref cnt = do
buf <- readIORef ref
let first = bufferFirst buf - count
let sel = bufferSelected buf

if first > 0
then writeIORef ref buf { bufferFirst = first
, bufferSelected = sel - count + 1
, bufferStatusBar = (bufferStatusBar buf) { sBarCurrent = sel - count + 1 }
}
else do

case listScrollUp (bufferList buf) cnt of
Just ls -> writeIORef ref buf { bufferList = ls
, bufferStatusBar = (bufferStatusBar buf) { sBarCurrent = listSelected ls }
}
Nothing -> do
msg <- themeFormatHitTheTop (bufferTheme buf)
writeIORef ref buf { bufferStatusMessage = (bufferStatusMessage buf) { sMessage = msg }
}

scrollDown :: (IORef Folder, Lock) -> Int -> Int -> IO ()
scrollDown (ref, lock) cols count = Lock.with lock $ scrollDown' ref cols count
scrollDown (ref, lock) cols cnt = Lock.with lock $ scrollDown' ref cols cnt

scrollDown' :: IORef Folder -> Int -> Int -> IO ()
scrollDown' ref cols count = do
scrollDown' ref cols cnt = do
buf <- readIORef ref
let len = length $ bufferLines buf
let first = bufferFirst buf + count
let sel = bufferSelected buf

if first + cols - 3 <= len
then writeIORef ref buf { bufferFirst = first
, bufferSelected = sel + count - 1
, bufferStatusBar = (bufferStatusBar buf) { sBarCurrent = sel + count - 1}
}
else do

case listScrollDown (bufferList buf) (toRegion cols 0) cnt of
Just ls -> writeIORef ref buf { bufferList = ls
, bufferStatusBar = (bufferStatusBar buf) { sBarCurrent = listSelected ls }
}
Nothing -> do
msg <- themeFormatHitTheBottom (bufferTheme buf)
writeIORef ref buf { bufferStatusMessage = (bufferStatusMessage buf) { sMessage = msg }
}

selectPrev :: (IORef Folder, Lock) -> Int -> IO ()
selectPrev (ref, lock) count = Lock.with lock $ selectPrev' ref count
selectPrev (ref, lock) cnt = Lock.with lock $ selectPrev' ref cnt

selectPrev' :: IORef Folder -> Int -> IO ()
selectPrev' ref count = do
selectPrev' ref cnt = do
buf <- readIORef ref
let first = bufferFirst buf
let sel = bufferSelected buf

if sel - count >= 1
then do
writeIORef ref buf { bufferSelected = sel - count
, bufferStatusBar = (bufferStatusBar buf) { sBarCurrent = sel - count }
}
when (sel - count < first) $ scrollUp' ref count
else do
case listSelectPrev (bufferList buf) cnt of
Just ls -> writeIORef ref buf { bufferList = ls
, bufferStatusBar = (bufferStatusBar buf) { sBarCurrent = listSelected ls }
}
Nothing -> do
msg <- themeFormatHitTheTop (bufferTheme buf)
writeIORef ref buf { bufferStatusMessage = (bufferStatusMessage buf) { sMessage = msg }
}

selectNext :: (IORef Folder, Lock) -> Int -> Int -> IO ()
selectNext (ref, lock) cols count = Lock.with lock $ selectNext' ref cols count
selectNext (ref, lock) cols cnt = Lock.with lock $ selectNext' ref cols cnt

selectNext' :: IORef Folder -> Int -> Int -> IO ()
selectNext' ref cols count = do
selectNext' ref cols cnt = do
buf <- readIORef ref
let sel = bufferSelected buf
let len = length $ bufferLines buf
let lst = bufferFirst buf + cols - 3

if sel + count <= len
then do
writeIORef ref buf { bufferSelected = sel + count
, bufferStatusBar = (bufferStatusBar buf) { sBarCurrent = sel + count }
}
when (sel + count > lst) $ scrollDown' ref cols count
else do

case listSelectNext (bufferList buf) (toRegion cols 0) cnt of
Just ls -> writeIORef ref buf { bufferList = ls
, bufferStatusBar = (bufferStatusBar buf) { sBarCurrent = listSelected ls }
}
Nothing -> do
msg <- themeFormatHitTheBottom (bufferTheme buf)
writeIORef ref buf { bufferStatusMessage = (bufferStatusMessage buf) { sMessage = msg }
}

termSelected :: IORef Folder -> IO String
termSelected ref = do
buf <- readIORef ref
let line = (bufferLines buf) !! (bufferSelected buf - 1)
return $ folderTerm line
let ls = bufferList buf
line = listIndex ls (listSelected ls)
return $ folderTerm $ lineData line

cancelLoad :: IORef Folder -> IO ()
cancelLoad ref = do
Expand All @@ -233,21 +215,23 @@ isCancelledLoad :: IORef Folder -> IO Bool
isCancelledLoad ref = do
buf <- readIORef ref
status <- tryTakeMVar (bufferCancel buf)
case status of
Just _ -> return True
Nothing -> return False
return $ isJust status

loadOne :: IORef Folder -> (String, String) -> Integer -> IO ()
loadOne ref (name, term) count = do
loadOne ref (name, term) cnt = do
buf <- readIORef ref
let len = length $ bufferLines buf
line = Line { lineIndex = len + 1
, folderName = name
, folderTerm = term
, folderCount = count
}

writeIORef ref buf { bufferLines = bufferLines buf ++ [line]

let theme = bufferTheme buf
len = listLength $ bufferList buf
ld = LineData { folderName = name
, folderTerm = term
, folderCount = cnt
}
line = Line { lineData = ld
, lineRender = (themeDrawLine theme) (themeAttrs theme)
}

writeIORef ref buf { bufferList = listAppend (bufferList buf) line
, bufferStatusBar = (bufferStatusBar buf) { sBarTotal = len + 1 }
}

Expand All @@ -262,12 +246,12 @@ load (ref, lock) mvar db ((name, term):xs) = do
putMVar mvar Redraw

(Just query) <- NM.queryCreate db term
count <- NM.queryCountMessages query
cnt <- NM.queryCountMessages query
NM.queryDestroy query

when (count > 0) $
when (cnt > 0) $
Lock.with lock $ do
loadOne ref (name, term) count
loadOne ref (name, term) cnt

buf <- readIORef ref
msg <- themeFormatLoadingDone (bufferTheme buf) (name, term)
Expand Down
Loading

0 comments on commit 5d3d825

Please sign in to comment.