Add a newtype wrapper for Pango markup

5 files changed, 121 insertions, 31 deletions

diff --git a/Bustle/Diagram.hs b/Bustle/Diagram.hs
index eb0eadc..c20fc8f 100644
--- a/Bustle/Diagram.hs
+++ b/Bustle/Diagram.hs
@@ -64,6 +64,9 @@ import Graphics.UI.Gtk.Pango.Layout
 import Graphics.UI.Gtk.Pango.Font
 #endif
 
+import qualified Bustle.Markup as Markup
+import Bustle.Markup (Markup)
+
 type Point = (Double, Double)
 type Rect = (Double, Double, Double, Double)
 
@@ -92,7 +95,8 @@ data Colour = Colour Double Double Double
 data Shape = Header { strs :: [String]
                     , shapex, shapey :: Double
                     }
-           | MemberLabel { labelPath, labelMember :: String
+           | MemberLabel { labelPath, labelInterface, labelMember :: String
+                         , shapeIsReturn :: Bool
                          , shapex :: Double -- The coordinates of the *centre*
                          , shapey :: Double -- of the label
                          }
@@ -115,8 +119,13 @@ data Shape = Header { strs :: [String]
 
 -- Smart constructors for TimestampLabel and MemberLabel that fill in the
 -- hardcoded (spit) x coordinates.
-memberLabel :: String -> String -> Double -> Shape
-memberLabel p m y = MemberLabel p m memberx y
+memberLabel :: String -- ^ object path
+            -> String -- ^ interface
+            -> String -- ^ method name
+            -> Bool   -- ^ True if this is a return; False if it's a call
+            -> Double -- ^ y-coordinate
+            -> Shape
+memberLabel p i m isReturn y = MemberLabel p i m isReturn memberx y
 
 timestampLabel :: String -> Double -> Shape
 timestampLabel s y = TimestampLabel s timestampx y
@@ -219,7 +228,7 @@ bounds s = case s of
        -- FIXME: magic 5 makes the bounding box include the text
     in (min x1 cx, y1, max x2 dx, y2 + 5)
   TimestampLabel { shapex=x, shapey=y } -> fromCentre x y timestampWidth
-  MemberLabel _ _ x y -> fromCentre x y memberWidth
+  MemberLabel { shapex=x, shapey=y } -> fromCentre x y memberWidth
   Header { strs = ss, shapex = x, shapey = y} ->
     let width = columnWidth
         height = headerHeight ss
@@ -320,7 +329,9 @@ draw s = draw' s
                         shapex2 <*> shapey
           Header {} -> drawHeader <$> strs <*> shapex <*> shapey
           MemberLabel {} -> drawMember <$> labelPath
+                                       <*> labelInterface
                                        <*> labelMember
+                                       <*> shapeIsReturn
                                        <*> shapex
                                        <*> shapey
           TimestampLabel {} -> drawTimestamp <$> str
@@ -383,7 +394,7 @@ drawArc cx cy dx dy x1 y1 x2 y2 cap = saved $ do
     stroke
 
     setSourceRGB 0 0 0
-    l <- mkLayout cap EllipsizeNone AlignLeft
+    l <- mkLayout (Markup.escape cap) EllipsizeNone AlignLeft
     (PangoRectangle _ _ textWidth _, _) <- liftIO $ layoutGetExtents l
     let tx = min x2 dx + abs (x2 - dx) / 2
     moveTo (if x1 > cx then tx - textWidth else tx) (y2 - 5)
@@ -397,12 +408,12 @@ font = do
     return fd
 
 mkLayout :: (MonadIO m)
-         => String -> EllipsizeMode -> LayoutAlignment
+         => Markup -> EllipsizeMode -> LayoutAlignment
          -> m PangoLayout
 mkLayout s e a = liftIO $ do
     ctx <- cairoCreateContext Nothing
     layout <- layoutEmpty ctx
-    layoutSetMarkup layout s
+    layoutSetMarkup layout (Markup.unMarkup s)
     layoutSetFontDescription layout . Just =<< font
     layoutSetEllipsize layout e
     layoutSetAlignment layout a
@@ -416,23 +427,29 @@ withWidth m w = do
 
 drawHeader :: [String] -> Double -> Double -> Render ()
 drawHeader names x y = forM_ (zip [0..] names) $ \(i, name) -> do
-    l <- mkLayout name EllipsizeEnd AlignCenter `withWidth` columnWidth
+    l <- mkLayout (Markup.escape name) EllipsizeEnd AlignCenter `withWidth` columnWidth
     moveTo (x - (columnWidth / 2)) (y + i * h)
     showLayout l
   where h = 10
 
-drawMember :: String -> String -> Double -> Double -> Render ()
-drawMember s1 s2 x y = dm s1 (y - 10) >> dm s2 y
+drawMember :: String -> String -> String -> Bool -> Double -> Double -> Render ()
+drawMember p i m isReturn x y = do
+    drawOne path (y - 10)
+    drawOne fullMethod y
   where
-    dm s y' = do
-      l <- mkLayout s EllipsizeStart AlignLeft `withWidth` memberWidth
+    drawOne markup y' = do
+      l <- mkLayout markup EllipsizeStart AlignLeft `withWidth` memberWidth
       moveTo (x - memberWidth / 2) y'
       showLayout l
 
+    path = (if isReturn then id else Markup.b) $ Markup.escape p
+    fullMethod =
+        (if isReturn then Markup.i else id) $ Markup.formatMember i m
+
 drawTimestamp :: String -> Double -> Double -> Render ()
 drawTimestamp ts x y = do
     moveTo (x - timestampWidth / 2) (y - 10)
-    showLayout =<< mkLayout ts EllipsizeNone AlignLeft `withWidth` timestampWidth
+    showLayout =<< mkLayout (Markup.escape ts) EllipsizeNone AlignLeft `withWidth` timestampWidth
 
 drawClientLine :: Double -> Double -> Double -> Render ()
 drawClientLine x y1 y2 = saved $ do
diff --git a/Bustle/Markup.hs b/Bustle/Markup.hs
new file mode 100644
index 0000000..4e0db7d
--- /dev/null
+++ b/Bustle/Markup.hs
@@ -0,0 +1,69 @@
+{-
+Bustle.Diagram: My First Type-Safe Markup Library
+Copyright © 2011 Will Thompson
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the GNU Lesser General Public
+License as published by the Free Software Foundation; either
+version 2.1 of the License, or (at your option) any later version.
+
+This library 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
+Lesser General Public License for more details.
+
+You should have received a copy of the GNU Lesser General Public
+License along with this library; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
+-}
+{-# LANGUAGE CPP #-}
+module Bustle.Markup
+  ( Markup
+  , unMarkup
+  , tag
+  , b
+  , i
+  , escape
+
+  , formatMember
+  )
+where
+
+import Data.Monoid
+
+#if MIN_VERSION_gtk(0,11,0)
+import Graphics.Rendering.Pango.Layout (escapeMarkup)
+#else
+import Graphics.UI.Gtk.Pango.Layout (escapeMarkup)
+#endif
+
+newtype Markup = Markup { unMarkup :: String }
+    deriving (Show, Read, Ord, Eq)
+
+instance Monoid Markup where
+    mempty = Markup ""
+    mappend x y = Markup (unMarkup x `mappend` unMarkup y)
+    mconcat = Markup . mconcat . map unMarkup
+
+--raw :: String -> Markup
+--raw = Markup
+
+tag :: String -> Markup -> Markup
+tag name contents =
+    Markup $ concat [ "<", name, ">"
+                    , unMarkup contents
+                    , "</", name, ">"
+                    ]
+
+b, i :: Markup -> Markup
+b = tag "b"
+i = tag "i"
+
+escape :: String -> Markup
+escape = Markup . escapeMarkup
+
+formatMember :: String -> String -> Markup
+formatMember iface member = mconcat [ escape iface
+                                    , escape "."
+                                    , b (escape member)
+                                    ]
diff --git a/Bustle/Renderer.hs b/Bustle/Renderer.hs
index a3a7f8c..81d991d 100644
--- a/Bustle/Renderer.hs
+++ b/Bustle/Renderer.hs
@@ -385,13 +385,7 @@ memberName :: Message -> Bool -> Renderer ()
 memberName message isReturn = do
     current <- gets row
     let Member p i m = member message
-        meth = i ++ "." ++ (b m)
-
-    shape $ memberLabel (it p) (it meth) current
-  where it x | isReturn  = "<i>" ++ x ++ "</i>"
-             | otherwise = x
-        b x  | isReturn  = x
-             | otherwise = "<b>" ++ x ++ "</b>"
+    shape $ memberLabel p i m isReturn current
 
 relativeTimestamp :: Message -> Renderer ()
 relativeTimestamp m = do
diff --git a/Bustle/StatisticsPane.hs b/Bustle/StatisticsPane.hs
index 46cf744..875a5ff 100644
--- a/Bustle/StatisticsPane.hs
+++ b/Bustle/StatisticsPane.hs
@@ -26,10 +26,12 @@ where
 import Control.Applicative ((<$>))
 import Control.Monad (forM_)
 import Text.Printf
-import Graphics.UI.Gtk
+import Graphics.UI.Gtk hiding (Markup)
 import Graphics.UI.Gtk.Glade
 import Bustle.Stats
 import Bustle.Types (Log)
+import qualified Bustle.Markup as Markup
+import Bustle.Markup (Markup)
 
 data StatsPane =
     StatsPane { spCountStore :: ListStore FrequencyInfo
@@ -67,20 +69,20 @@ statsPaneSetMessages sp sessionMessages systemMessages = do
 addTextRenderer :: TreeViewColumn
                 -> ListStore a
                 -> Bool
-                -> (a -> String)
+                -> (a -> Markup)
                 -> IO CellRendererText
 addTextRenderer col store expand f = do
     renderer <- cellRendererTextNew
     cellLayoutPackStart col renderer expand
     set renderer [ cellTextSizePoints := 7 ]
     cellLayoutSetAttributes col renderer store $ \x ->
-        [ cellTextMarkup := Just $ f x ]
+        [ cellTextMarkup := Just . Markup.unMarkup $ f x ]
     return renderer
 
 addMemberRenderer :: TreeViewColumn
                   -> ListStore a
                   -> Bool
-                  -> (a -> String)
+                  -> (a -> Markup)
                   -> IO CellRendererText
 addMemberRenderer col store expand f = do
     renderer <- addTextRenderer col store expand f
@@ -94,7 +96,7 @@ addMemberRenderer col store expand f = do
 addStatColumn :: TreeView
               -> ListStore a
               -> String
-              -> (a -> String)
+              -> (a -> Markup)
               -> IO ()
 addStatColumn view store title f = do
     col <- treeViewColumnNew
@@ -104,6 +106,14 @@ addStatColumn view store title f = do
     treeViewAppendColumn view col
     return ()
 
+addTextStatColumn :: TreeView
+                  -> ListStore a
+                  -> String
+                  -> (a -> String)
+                  -> IO ()
+addTextStatColumn view store title f =
+    addStatColumn view store title (Markup.escape . f)
+
 newCountView :: Maybe Pixbuf
              -> Maybe Pixbuf
              -> IO (ListStore FrequencyInfo, TreeView)
@@ -133,7 +143,7 @@ newCountView method signal = do
       _ -> return ()
 
   addMemberRenderer nameColumn countStore True $ \fi ->
-      fiInterface fi ++ ".<b>" ++ fiMember fi ++ "</b>"
+      Markup.formatMember (fiInterface fi) (fiMember fi)
   treeViewAppendColumn countView nameColumn
 
   countColumn <- treeViewColumnNew
@@ -172,13 +182,13 @@ newTimeView = do
                  ]
 
   addMemberRenderer nameColumn timeStore True $ \ti ->
-      tiInterface ti ++ "<b>" ++ tiMethodName ti ++ "</b>"
+      Markup.formatMember (tiInterface ti) (tiMethodName ti)
   treeViewAppendColumn timeView nameColumn
 
-  addStatColumn timeView timeStore "Total"
+  addTextStatColumn timeView timeStore "Total"
                 (printf "%.1f ms" . tiTotalTime)
-  addStatColumn timeView timeStore "Calls" (show . tiCallFrequency)
-  addStatColumn timeView timeStore "Mean"
+  addTextStatColumn timeView timeStore "Calls" (show . tiCallFrequency)
+  addTextStatColumn timeView timeStore "Mean"
                 (printf "%.1f ms" . tiMeanCallTime)
 
   return (timeStore, timeView)
diff --git a/bustle.cabal b/bustle.cabal
index 594f0d8..b212c82 100644
--- a/bustle.cabal
+++ b/bustle.cabal
@@ -27,7 +27,7 @@ Executable bustle
   Main-is:        Bustle.hs
   Other-modules:  Bustle.Types, Bustle.Parser, Bustle.Diagram, Bustle.Renderer,
                   Bustle.Upgrade, Bustle.Application.Monad, Bustle.Util,
-                  Bustle.StatisticsPane
+                  Bustle.StatisticsPane, Bustle.Markup
   Ghc-options:    -Wall -fno-warn-unused-imports -fno-warn-unused-do-bind
 
   if flag(PostCabalizedGtk2HS)