Merge pull request #107 from maoe/ghc-events-unicode

Update ghc-events to 0.13.0

Author: maoe

Events/HECs.hs

@@ -16,6 +16,7 @@ import Events.SparkTree
 import GHC.RTS.Events
 
 import Data.Array
+import Data.Text (Text)
 import qualified Data.List as L
 
 #if MIN_VERSION_containers(0,5,0)
@@ -37,7 +38,7 @@ data HECs = HECs {
        maxXHistogram    :: Int,
        maxYHistogram    :: Timestamp,
        durHistogram     :: [(Timestamp, Int, Timestamp)],
-       perfNames        :: IM.IntMap String
+       perfNames        :: IM.IntMap Text
      }
 
 -----------------------------------------------------------------------------
@@ -60,7 +61,7 @@ timestampToEventIndex HECs{hecEventArray=arr} ts =
         mid  = l + (r - l) `quot` 2
         tmid = evTime (arr!mid)
 
-extractUserMarkers :: HECs -> [(Timestamp, String)]
+extractUserMarkers :: HECs -> [(Timestamp, Text)]
 extractUserMarkers hecs =
   [ (ts, mark)
   | (Event ts (UserMarker mark) _) <- elems (hecEventArray hecs) ]

Events/TestEvents.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE OverloadedStrings #-}
 module Events.TestEvents (testTrace)
 where
 

GUI/BookmarkView.hs

@@ -15,13 +15,14 @@ import GHC.RTS.Events (Timestamp)
 import Graphics.UI.Gtk
 import qualified Graphics.UI.Gtk.ModelView.TreeView.Compat as Compat
 import Numeric
+import Data.Text (Text)
 
 ---------------------------------------------------------------------------
 
 -- | Abstract bookmark view object.
 --
 data BookmarkView = BookmarkView {
-       bookmarkStore :: ListStore (Timestamp, String)
+       bookmarkStore :: ListStore (Timestamp, Text)
      }
 
 -- | The actions to take in response to TraceView events.
@@ -30,12 +31,12 @@ data BookmarkViewActions = BookmarkViewActions {
        bookmarkViewAddBookmark    :: IO (),
        bookmarkViewRemoveBookmark :: Int -> IO (),
        bookmarkViewGotoBookmark   :: Timestamp -> IO (),
-       bookmarkViewEditLabel      :: Int -> String -> IO ()
+       bookmarkViewEditLabel      :: Int -> Text -> IO ()
      }
 
 ---------------------------------------------------------------------------
 
-bookmarkViewAdd :: BookmarkView -> Timestamp -> String -> IO ()
+bookmarkViewAdd :: BookmarkView -> Timestamp -> Text -> IO ()
 bookmarkViewAdd BookmarkView{bookmarkStore} ts label = do
   listStoreAppend bookmarkStore (ts, label)
   return ()
@@ -49,11 +50,11 @@ bookmarkViewClear :: BookmarkView -> IO ()
 bookmarkViewClear BookmarkView{bookmarkStore} =
   listStoreClear bookmarkStore
 
-bookmarkViewGet :: BookmarkView -> IO [(Timestamp, String)]
+bookmarkViewGet :: BookmarkView -> IO [(Timestamp, Text)]
 bookmarkViewGet BookmarkView{bookmarkStore} =
   listStoreToList bookmarkStore
 
-bookmarkViewSetLabel :: BookmarkView -> Int -> String -> IO ()
+bookmarkViewSetLabel :: BookmarkView -> Int -> Text -> IO ()
 bookmarkViewSetLabel BookmarkView{bookmarkStore} n label = do
   (ts,_) <- listStoreGetValue bookmarkStore n
   listStoreSetValue bookmarkStore n (ts, label)

GUI/EventsView.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
 module GUI.EventsView (
     EventsView,
     eventsViewNew,
@@ -18,9 +19,14 @@ import qualified GUI.GtkExtras as GtkExt
 
 import Control.Monad.Reader
 import Data.Array
+import Data.Monoid
 import Data.IORef
 import qualified Data.Text as T
+import qualified Data.Text.Lazy as TL
+import qualified Data.Text.Lazy.Builder as TB
+import qualified Data.Text.Lazy.Builder.Int as TB (decimal)
 import Numeric
+import Prelude
 
 -------------------------------------------------------------------------------
 
@@ -55,8 +61,8 @@ eventsViewNew builder EventsViewActions{..} = do
   stateRef <- newIORef undefined
 
   let getWidget cast = builderGetObject builder cast
-  drawArea     <- getWidget castToWidget "eventsDrawingArea"
-  vScrollbar   <- getWidget castToVScrollbar "eventsVScroll"
+  drawArea     <- getWidget castToWidget ("eventsDrawingArea" :: T.Text)
+  vScrollbar   <- getWidget castToVScrollbar ("eventsVScroll" :: T.Text)
   adj          <- get vScrollbar rangeAdjustment
 
   -- make the background white
@@ -339,16 +345,14 @@ drawEvents EventsView{drawArea, adj}
   where
     showEventTime (Event time _spec _) =
       showFFloat (Just 6) (fromIntegral time / 1000000) "s"
-    showEventDescr :: Event -> String
-    showEventDescr (Event _time  spec cap) =
-        (case cap of
-          Nothing -> ""
-          Just c  -> "HEC " ++ show c ++ ": ")
-     ++ case spec of
-          UnknownEvent{ref} -> "unknown event; " ++ show ref
-          Message     msg   -> msg
-          UserMessage msg   -> msg
-          _                 -> showEventInfo spec
+    showEventDescr :: Event -> T.Text
+    showEventDescr (Event _time  spec cap) = TL.toStrict $ TB.toLazyText $
+      maybe "" (\c -> "HEC " <> TB.decimal c <> ": ") cap
+        <> case spec of
+          UnknownEvent{ref} -> "unknown event; " <> TB.decimal ref
+          Message     msg   -> TB.fromText msg
+          UserMessage msg   -> TB.fromText msg
+          _                 -> buildEventInfo spec
 
 -------------------------------------------------------------------------------
 

GUI/Main.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE OverloadedStrings #-}
 module GUI.Main (runGUI) where
 
 -- Imports for GTK
@@ -16,6 +17,7 @@ import qualified Control.Concurrent.Chan as Chan
 import Control.Exception
 import Data.Array
 import Data.Maybe
+import Data.Text (Text)
 
 -- Imports for ThreadScope
 import qualified GUI.App as App
@@ -108,7 +110,7 @@ data Event
 
    | EventBookmarkAdd
    | EventBookmarkRemove Int
-   | EventBookmarkEdit   Int String
+   | EventBookmarkEdit   Int Text
 
    | EventUserError String SomeException
                     -- can add more specific ones if necessary

GUI/StartupInfoView.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ViewPatterns #-}
 module GUI.StartupInfoView (
     StartupInfoView,
     startupInfoViewNew,
@@ -14,25 +16,27 @@ import Data.List
 import Data.Maybe
 import Data.Time
 import Data.Time.Clock.POSIX
+import Data.Text (Text)
+import qualified Data.Text as T
 
 -------------------------------------------------------------------------------
 
 data StartupInfoView = StartupInfoView
      { labelProgName      :: Label
-     , storeProgArgs      :: ListStore String
-     , storeProgEnv       :: ListStore (String, String)
+     , storeProgArgs      :: ListStore Text
+     , storeProgEnv       :: ListStore (Text, Text)
      , labelProgStartTime :: Label
      , labelProgRtsId     :: Label
      }
 
 data StartupInfoState
    = StartupInfoEmpty
    | StartupInfoLoaded
-     { progName      :: Maybe String
-     , progArgs      :: Maybe [String]
-     , progEnv       :: Maybe [(String, String)]
+     { progName      :: Maybe Text
+     , progArgs      :: Maybe [Text]
+     , progEnv       :: Maybe [(Text, Text)]
      , progStartTime :: Maybe UTCTime
-     , progRtsId     :: Maybe String
+     , progRtsId     :: Maybe Text
      }
 
 -------------------------------------------------------------------------------
@@ -42,11 +46,11 @@ startupInfoViewNew builder = do
 
     let getWidget cast = builderGetObject builder cast
 
-    labelProgName      <- getWidget castToLabel    "labelProgName"
-    treeviewProgArgs   <- getWidget castToTreeView "treeviewProgArguments"
-    treeviewProgEnv    <- getWidget castToTreeView "treeviewProgEnvironment"
-    labelProgStartTime <- getWidget castToLabel    "labelProgStartTime"
-    labelProgRtsId     <- getWidget castToLabel    "labelProgRtsIdentifier"
+    labelProgName      <- getWidget castToLabel    ("labelProgName" :: Text)
+    treeviewProgArgs   <- getWidget castToTreeView ("treeviewProgArguments" :: Text)
+    treeviewProgEnv    <- getWidget castToTreeView ("treeviewProgEnvironment" :: Text)
+    labelProgStartTime <- getWidget castToLabel    ("labelProgStartTime" :: Text)
+    labelProgRtsId     <- getWidget castToLabel    ("labelProgRtsIdentifier" :: Text)
 
     storeProgArgs    <- listStoreNew []
     columnArgs       <- treeViewColumnNew
@@ -126,7 +130,7 @@ processEvents = foldl' accum (StartupInfoLoaded Nothing Nothing Nothing Nothing
     accum info _ = info
 
     -- convert ["foo=bar", ...] to [("foo", "bar"), ...]
-    parseEnv env = [ (var, value) | (var, '=':value) <- map (span (/='=')) env ]
+    parseEnv env = [ (var, value) | (var, T.drop 1 -> value) <- map (T.span (/='=')) env ]
 
 updateStartupInfo :: StartupInfoView -> StartupInfoState -> IO ()
 updateStartupInfo StartupInfoView{..} StartupInfoLoaded{..} = do
@@ -139,8 +143,8 @@ updateStartupInfo StartupInfoView{..} StartupInfoLoaded{..} = do
     mapM_ (listStoreAppend storeProgEnv) (fromMaybe [] progEnv)
 
 updateStartupInfo StartupInfoView{..} StartupInfoEmpty = do
-    set labelProgName      [ labelText := "" ]
-    set labelProgStartTime [ labelText := "" ]
-    set labelProgRtsId     [ labelText := "" ]
+    set labelProgName      [ labelText := ("" :: Text) ]
+    set labelProgStartTime [ labelText := ("" :: Text) ]
+    set labelProgRtsId     [ labelText := ("" :: Text) ]
     listStoreClear storeProgArgs
     listStoreClear storeProgEnv

GUI/Timeline/HEC.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE OverloadedStrings #-}
 module GUI.Timeline.HEC (
     renderHEC,
     renderInstantHEC,
@@ -19,9 +20,16 @@ import qualified GHC.RTS.Events as GHC
 import Control.Monad
 import qualified Data.IntMap as IM
 import Data.Maybe
+import Data.Monoid
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Text.Lazy as TL
+import qualified Data.Text.Lazy.Builder as TB
+import qualified Data.Text.Lazy.Builder.Int as TB (decimal)
+import Prelude
 
 renderHEC :: ViewParameters -> Timestamp -> Timestamp
-          -> IM.IntMap String -> (DurationTree,EventTree)
+          -> IM.IntMap Text -> (DurationTree,EventTree)
           -> Render ()
 renderHEC params@ViewParameters{..} start end perfNames (dtree,etree) = do
   renderDurations params start end dtree
@@ -33,7 +41,7 @@ renderHEC params@ViewParameters{..} start end perfNames (dtree,etree) = do
          return ()
 
 renderInstantHEC :: ViewParameters -> Timestamp -> Timestamp
-                 -> IM.IntMap String -> EventTree
+                 -> IM.IntMap Text -> EventTree
                  -> Render ()
 renderInstantHEC params@ViewParameters{..} start end
                  perfNames (EventTree ltime etime tree) = do
@@ -78,7 +86,7 @@ renderEvents :: ViewParameters
              -> Timestamp -- start time of this tree node
              -> Timestamp -- end   time of this tree node
              -> Timestamp -> Timestamp -> Double
-             -> IM.IntMap String -> EventNode
+             -> IM.IntMap Text -> EventNode
              -> Render Bool
 
 renderEvents params@ViewParameters{..} !_s !_e !startPos !endPos ewidth
@@ -200,7 +208,7 @@ drawDuration ViewParameters{..} (ThreadRun t s startTime endTime) = do
    -- Optionally write the reason for the thread being stopped
    -- depending on the zoom value
   labelAt labelsMode endTime $
-    show t ++ " " ++ showThreadStopStatus s
+    T.pack $ show t ++ " " ++ showThreadStopStatus s
  where
   rectWidth = truncate (fromIntegral (endTime - startTime) / scaleValue) -- as pixels
   tStr = show t
@@ -226,7 +234,7 @@ gcBar col !startTime !endTime = do
                      (endTime - startTime)          -- w
                      (hecBarHeight `div` 2)         -- h
 
-labelAt :: Bool -> Timestamp -> String -> Render ()
+labelAt :: Bool -> Timestamp -> Text -> Render ()
 labelAt labelsMode t str
   | not labelsMode = return ()
   | otherwise = do
@@ -238,7 +246,7 @@ labelAt labelsMode t str
        showText str
        restore
 
-drawEvent :: ViewParameters -> Double -> IM.IntMap String -> GHC.Event
+drawEvent :: ViewParameters -> Double -> IM.IntMap Text -> GHC.Event
           -> Render Bool
 drawEvent params@ViewParameters{..} ewidth perfNames event =
   let renderI = renderInstantEvent params perfNames event ewidth
@@ -270,24 +278,29 @@ drawEvent params@ViewParameters{..} ewidth perfNames event =
 
     _ -> return False
 
-renderInstantEvent :: ViewParameters -> IM.IntMap String -> GHC.Event
+renderInstantEvent :: ViewParameters -> IM.IntMap Text -> GHC.Event
                    -> Double -> Color
                    -> Render Bool
 renderInstantEvent ViewParameters{..} perfNames event ewidth color = do
   setSourceRGBAhex color 1.0
   setLineWidth (ewidth * scaleValue)
   let t = evTime event
   draw_line (t, hecBarOff-4) (t, hecBarOff+hecBarHeight+4)
-  let numToLabel PerfCounter{perfNum, period} | period == 0 =
+  let numToLabel :: EventInfo -> Maybe Text
+      numToLabel PerfCounter{perfNum, period} | period == 0 =
         IM.lookup (fromIntegral perfNum) perfNames
-      numToLabel PerfCounter{perfNum, period} =
-        fmap (++ " <" ++ show (period + 1) ++ " times>") $
-          IM.lookup (fromIntegral perfNum) perfNames
-      numToLabel PerfTracepoint{perfNum} =
-        fmap ("tracepoint: " ++) $ IM.lookup (fromIntegral perfNum) perfNames
+      numToLabel PerfCounter{perfNum, period} = do
+        name <- IM.lookup (fromIntegral perfNum) perfNames
+        return $ toText $
+          TB.fromText name <> " <" <> TB.decimal (period + 1) <> " times>"
+      numToLabel PerfTracepoint{perfNum} = do
+        name <- IM.lookup (fromIntegral perfNum) perfNames
+        return $ toText $ "tracepoint: " <> TB.fromText name
       numToLabel _ = Nothing
-      showLabel espec = fromMaybe (showEventInfo espec) (numToLabel espec)
+      showLabel espec = fromMaybe (toText $ buildEventInfo espec) (numToLabel espec)
   labelAt labelsMode t $ showLabel (evSpec event)
   return True
+  where
+    toText = TL.toStrict . TB.toLazyText
 
 -------------------------------------------------------------------------------

threadscope.cabal

@@ -56,7 +56,7 @@ Executable threadscope
                      array < 0.6,
                      mtl < 2.3,
                      filepath < 1.5,
-                     ghc-events >= 0.5 && < 0.13,
+                     ghc-events >= 0.13 && < 0.14,
                      containers >= 0.2 && < 0.7,
                      deepseq >= 1.1,
                      text < 1.3,