dramatic speedup of the gtk frontend

AllureOfTheStars · Apr 5, 2011 · 1413f3e · 1413f3e
1 parent c89bea5
commit 1413f3e
Showing 1 changed file with 27 additions and 15 deletions.
diff --git a/src/Display/Gtk.hs b/src/Display/Gtk.hs
@@ -100,22 +100,34 @@ display ((y0,x0), (y1,x1)) session f msg status =
   postGUIAsync $
   do
     tb <- textViewGetBuffer (sview session)
-    let memo  = [ unzip [ f (y, x) | x <- [x0..x1] ] | y <- [y0..y1] ]
+    let memo  = [ let (as, cs) = unzip [ f (y, x) | x <- [x0..x1] ]
-        chars = L.map snd memo
+                  in  ((y, as), cs)
+                | y <- [y0..y1] ]
         attrs = L.map fst memo
-        atrrAt (y, x) = attrs L.!! (y - y0) L.!! (x - x0)
+        chars = L.map snd memo
-    textBufferSetText tb (msg ++ "\n" ++ unlines chars ++ status)
+    textBufferSetText tb (msg ++ "\n" ++ unlines chars ++ status)  -- TODO: BS
-    sequence_ [ setTo tb (stags session) (y, x) (atrrAt (y, x))
+    mapM_ (setTo tb (stags session) x0) attrs
-              | y <- [y0..y1], x <- [x0..x1]]
+
-
+setTo :: TextBuffer -> Map Color.Attr TextTag -> X -> (Y, [Color.Attr]) -> IO ()
-setTo :: TextBuffer -> Map Color.Attr TextTag -> Loc -> Color.Attr -> IO ()
+setTo tb tts lx (ly, []) = return ()
-setTo tb tts (ly, lx) a
+setTo tb tts lx (ly, a:as) = do
-  | a == Color.defaultAttr = return ()
+  ib <- textBufferGetIterAtLineOffset tb (ly + 1) lx
-  | otherwise = do
+  ie <- textIterCopy ib
-      ib <- textBufferGetIterAtLineOffset tb (ly + 1) lx
+  let setIter :: Color.Attr -> Int -> [Color.Attr] -> IO ()
-      ie <- textIterCopy ib
+      setIter previous repetitions [] = do
-      textIterForwardChar ie
+        textIterForwardChars ie repetitions
-      textBufferApplyTag tb (tts ! a) ib ie
+        when (previous /= Color.defaultAttr) $
+          textBufferApplyTag tb (tts ! previous) ib ie
+      setIter previous repetitions (a:as)
+        | a == previous =
+            setIter a (repetitions + 1) as
+        | otherwise = do
+            textIterForwardChars ie repetitions
+            when (previous /= Color.defaultAttr) $
+              textBufferApplyTag tb (tts ! previous) ib ie
+            textIterForwardChars ib repetitions
+            setIter a 1 as
+  setIter a 1 as
 
 -- | reads until a non-dead key encountered
 readUndeadChan :: Chan String -> IO String