1{-# LANGUAGE CPP #-}
2{-# LANGUAGE OverloadedStrings #-}
3module GUI.EventsView (
4    EventsView,
5    eventsViewNew,
6    EventsViewActions(..),
7
8    eventsViewSetEvents,
9
10    eventsViewGetCursor,
11    eventsViewSetCursor,
12    eventsViewScrollToLine,
13  ) where
14
15import GHC.RTS.Events
16
17import Graphics.UI.Gtk
18import qualified GUI.GtkExtras as GtkExt
19
20import Control.Monad.Reader
21import Data.Array
22import Data.Monoid
23import Data.IORef
24import qualified Data.Text as T
25import qualified Data.Text.Lazy as TL
26import qualified Data.Text.Lazy.Builder as TB
27import qualified Data.Text.Lazy.Builder.Int as TB (decimal)
28import Numeric
29import Prelude
30
31-------------------------------------------------------------------------------
32
33data EventsView = EventsView {
34       drawArea :: !Widget,
35       adj      :: !Adjustment,
36       stateRef :: !(IORef ViewState)
37     }
38
39data EventsViewActions = EventsViewActions {
40       eventsViewCursorChanged :: Int -> IO ()
41     }
42
43data ViewState = ViewState {
44       lineHeight  :: !Double,
45       eventsState :: !EventsState
46     }
47
48data EventsState
49   = EventsEmpty
50   | EventsLoaded {
51       cursorPos :: !Int,
52       mrange    :: !(Maybe (Int, Int)),
53       eventsArr :: Array Int Event
54     }
55
56-------------------------------------------------------------------------------
57
58eventsViewNew :: Builder -> EventsViewActions -> IO EventsView
59eventsViewNew builder EventsViewActions{..} = do
60
61  stateRef <- newIORef undefined
62
63  let getWidget cast = builderGetObject builder cast
64  drawArea     <- getWidget castToWidget ("eventsDrawingArea" :: T.Text)
65  vScrollbar   <- getWidget castToVScrollbar ("eventsVScroll" :: T.Text)
66  adj          <- get vScrollbar rangeAdjustment
67
68  -- make the background white
69  widgetModifyBg drawArea StateNormal (Color 0xffff 0xffff 0xffff)
70  widgetSetCanFocus drawArea True
71  --TODO: needs to be reset on each style change ^^
72
73  -----------------------------------------------------------------------------
74  -- Line height
75
76  -- Calculate the height of each line based on the current font
77  let getLineHeight = do
78        pangoCtx <- widgetGetPangoContext drawArea
79        fontDesc <- contextGetFontDescription pangoCtx
80        metrics  <- contextGetMetrics pangoCtx fontDesc emptyLanguage
81        return $ ascent metrics + descent metrics --TODO: padding?
82
83  -- We cache the height of each line
84  initialLineHeight <- getLineHeight
85  -- but have to update it when the font changes
86  on drawArea styleSet $ \_ -> do
87    lineHeight' <- getLineHeight
88    modifyIORef stateRef $ \viewstate -> viewstate { lineHeight = lineHeight' }
89
90  -----------------------------------------------------------------------------
91
92  writeIORef stateRef ViewState {
93    lineHeight  = initialLineHeight,
94    eventsState = EventsEmpty
95  }
96
97  let eventsView = EventsView {..}
98
99  -----------------------------------------------------------------------------
100  -- Drawing
101
102  on drawArea exposeEvent $ liftIO $ do
103    drawEvents eventsView =<< readIORef stateRef
104    return True
105
106  -----------------------------------------------------------------------------
107  -- Key navigation
108
109  on drawArea keyPressEvent $ do
110    let scroll by = liftIO $ do
111          ViewState{eventsState, lineHeight} <- readIORef stateRef
112          pagesize <- get adj adjustmentPageSize
113          let pagejump = max 1 (truncate (pagesize / lineHeight) - 1)
114          case eventsState of
115            EventsEmpty                        -> return ()
116            EventsLoaded{cursorPos, eventsArr} ->
117                eventsViewCursorChanged cursorPos'
118              where
119                cursorPos'    = clampBounds range (by pagejump end cursorPos)
120                range@(_,end) = bounds eventsArr
121          return True
122
123    key <- eventKeyName
124#if MIN_VERSION_gtk(0,13,0)
125    case T.unpack key of
126#else
127    case key of
128#endif
129      "Up"        -> scroll (\_page _end  pos -> pos-1)
130      "Down"      -> scroll (\_page _end  pos -> pos+1)
131      "Page_Up"   -> scroll (\ page _end  pos -> pos-page)
132      "Page_Down" -> scroll (\ page _end  pos -> pos+page)
133      "Home"      -> scroll (\_page _end _pos -> 0)
134      "End"       -> scroll (\_page  end _pos -> end)
135      "Left"      -> return True
136      "Right"     -> return True
137      _           -> return False
138
139  -----------------------------------------------------------------------------
140  -- Scrolling
141
142  set adj [ adjustmentLower := 0 ]
143
144  on drawArea sizeAllocate $ \_ ->
145    updateScrollAdjustment eventsView =<< readIORef stateRef
146
147  let hitpointToLine :: ViewState -> Double -> Double -> Maybe Int
148      hitpointToLine ViewState{eventsState = EventsEmpty} _ _  = Nothing
149      hitpointToLine ViewState{eventsState = EventsLoaded{eventsArr}, lineHeight}
150                     yOffset eventY
151        | hitLine > maxIndex = Nothing
152        | otherwise          = Just hitLine
153        where
154          hitLine  = truncate ((yOffset + eventY) / lineHeight)
155          maxIndex = snd (bounds eventsArr)
156
157  on drawArea buttonPressEvent $ tryEvent $ do
158    (_,y)  <- eventCoordinates
159    liftIO $ do
160      viewState <- readIORef stateRef
161      yOffset <- get adj adjustmentValue
162      widgetGrabFocus drawArea
163      case hitpointToLine viewState yOffset y of
164        Nothing -> return ()
165        Just n  -> eventsViewCursorChanged n
166
167  on drawArea scrollEvent $ do
168    dir <- eventScrollDirection
169    liftIO $ do
170      val      <- get adj adjustmentValue
171      upper    <- get adj adjustmentUpper
172      pagesize <- get adj adjustmentPageSize
173      step     <- get adj adjustmentStepIncrement
174      case dir of
175        ScrollUp   -> set adj [ adjustmentValue := val - step ]
176        ScrollDown -> set adj [ adjustmentValue := min (val + step)
177                                                       (upper - pagesize) ]
178        _          -> return ()
179    return True
180
181  onValueChanged adj $
182    widgetQueueDraw drawArea
183
184  -----------------------------------------------------------------------------
185
186  return eventsView
187
188-------------------------------------------------------------------------------
189
190eventsViewSetEvents :: EventsView -> Maybe (Array Int Event) -> IO ()
191eventsViewSetEvents eventWin@EventsView{drawArea, stateRef} mevents = do
192  viewState <- readIORef stateRef
193  let eventsState' = case mevents of
194        Nothing     -> EventsEmpty
195        Just events -> EventsLoaded {
196                          cursorPos  = 0,
197                          mrange = Nothing,
198                          eventsArr  = events
199                       }
200      viewState' = viewState { eventsState = eventsState' }
201  writeIORef stateRef viewState'
202  updateScrollAdjustment eventWin viewState'
203  widgetQueueDraw drawArea
204
205-------------------------------------------------------------------------------
206
207eventsViewGetCursor :: EventsView -> IO (Maybe Int)
208eventsViewGetCursor EventsView{stateRef} = do
209  ViewState{eventsState} <- readIORef stateRef
210  case eventsState of
211    EventsEmpty             -> return Nothing
212    EventsLoaded{cursorPos} -> return (Just cursorPos)
213
214eventsViewSetCursor :: EventsView -> Int -> Maybe (Int, Int) -> IO ()
215eventsViewSetCursor eventsView@EventsView{drawArea, stateRef} n mrange = do
216  viewState@ViewState{eventsState} <- readIORef stateRef
217  case eventsState of
218    EventsEmpty             -> return ()
219    EventsLoaded{eventsArr} -> do
220      let n' = clampBounds (bounds eventsArr) n
221      writeIORef stateRef viewState {
222        eventsState = eventsState { cursorPos = n', mrange }
223      }
224      eventsViewScrollToLine eventsView  n'
225      widgetQueueDraw drawArea
226
227eventsViewScrollToLine :: EventsView -> Int -> IO ()
228eventsViewScrollToLine EventsView{adj, stateRef} n = do
229  ViewState{lineHeight} <- readIORef stateRef
230  -- make sure that the range [n..n+1] is within the current page:
231  adjustmentClampPage adj
232    (fromIntegral  n    * lineHeight)
233    (fromIntegral (n+1) * lineHeight)
234
235-------------------------------------------------------------------------------
236
237updateScrollAdjustment :: EventsView -> ViewState -> IO ()
238updateScrollAdjustment EventsView{drawArea, adj}
239                       ViewState{lineHeight, eventsState} = do
240
241  (_,windowHeight) <- widgetGetSize drawArea
242  let numLines = case eventsState of
243                   EventsEmpty             -> 0
244                   EventsLoaded{eventsArr} -> snd (bounds eventsArr) + 1
245      linesHeight = fromIntegral numLines * lineHeight
246      upper       = max linesHeight (fromIntegral windowHeight)
247      pagesize    = fromIntegral windowHeight
248
249  set adj [
250       adjustmentUpper         := upper,
251       adjustmentPageSize      := pagesize,
252       adjustmentStepIncrement := pagesize * 0.2,
253       adjustmentPageIncrement := pagesize * 0.9
254    ]
255  val <- get adj adjustmentValue
256  when (val > upper - pagesize) $
257    set adj [ adjustmentValue := max 0 (upper - pagesize) ]
258
259-------------------------------------------------------------------------------
260
261drawEvents :: EventsView -> ViewState -> IO ()
262drawEvents _ ViewState {eventsState = EventsEmpty} = return ()
263drawEvents EventsView{drawArea, adj}
264           ViewState {lineHeight, eventsState = EventsLoaded{..}} = do
265
266  yOffset    <- get adj adjustmentValue
267  pageSize   <- get adj adjustmentPageSize
268
269  -- calculate which lines are visible
270  let lower = truncate (yOffset / lineHeight)
271      upper = ceiling ((yOffset + pageSize) / lineHeight)
272
273      -- the array indexes [begin..end] inclusive
274      -- are partially or fully visible
275      begin = lower
276      end   = min upper (snd (bounds eventsArr))
277
278  win   <- widgetGetDrawWindow drawArea
279  style <- get drawArea widgetStyle
280  focused <- get drawArea widgetIsFocus
281  let state | focused   = StateSelected
282            | otherwise = StateActive
283
284  pangoCtx <- widgetGetPangoContext drawArea
285  layout   <- layoutEmpty pangoCtx
286  layoutSetEllipsize layout EllipsizeEnd
287
288  (width,clipHeight) <- widgetGetSize drawArea
289  let clipRect = Rectangle 0 0 width clipHeight
290
291  let -- With average char width, timeWidth is enough for 24 hours of logs
292      -- (way more than TS can handle, currently). Aligns nicely with
293      -- current timeline_yscale_area width, too.
294      -- TODO: take timeWidth from the yScaleDrawingArea width
295      -- TODO: perhaps make the timeWidth area grey, too?
296      -- TODO: perhaps limit scroll to the selected interval (perhaps not strictly, but only so that the interval area does not completely vanish from the visible area)?
297      timeWidth  = 105
298      columnGap  = 20
299      descrWidth = width - timeWidth - columnGap
300
301  sequence_
302    [ do when (inside || selected) $
303           GtkExt.stylePaintFlatBox
304             style win
305             state1 ShadowNone
306             clipRect
307             drawArea ""
308             0 (round y) width (round lineHeight)
309
310         -- The event time
311         layoutSetText layout (showEventTime event)
312         layoutSetAlignment layout AlignRight
313         layoutSetWidth layout (Just (fromIntegral timeWidth))
314         GtkExt.stylePaintLayout
315           style win
316           state2 True
317           clipRect
318           drawArea ""
319           0 (round y)
320           layout
321
322         -- The event description text
323         layoutSetText layout (showEventDescr event)
324         layoutSetAlignment layout AlignLeft
325         layoutSetWidth layout (Just (fromIntegral descrWidth))
326         GtkExt.stylePaintLayout
327           style win
328           state2 True
329           clipRect
330           drawArea ""
331           (timeWidth + columnGap) (round y)
332           layout
333
334    | n <- [begin..end]
335    , let y = fromIntegral n * lineHeight - yOffset
336          event    = eventsArr ! n
337          inside   = maybe False (\ (s, e) -> s <= n && n <= e) mrange
338          selected = cursorPos == n
339          (state1, state2)
340            | inside    = (StatePrelight, StatePrelight)
341            | selected  = (state, state)
342            | otherwise = (state, StateNormal)
343    ]
344
345  where
346    showEventTime (Event time _spec _) =
347      showFFloat (Just 6) (fromIntegral time / 1000000) "s"
348    showEventDescr :: Event -> T.Text
349    showEventDescr (Event _time  spec cap) = TL.toStrict $ TB.toLazyText $
350      maybe "" (\c -> "HEC " <> TB.decimal c <> ": ") cap
351        <> case spec of
352          UnknownEvent{ref} -> "unknown event; " <> TB.decimal ref
353          Message     msg   -> TB.fromText msg
354          UserMessage msg   -> TB.fromText msg
355          _                 -> buildEventInfo spec
356
357-------------------------------------------------------------------------------
358
359clampBounds :: Ord a => (a, a) -> a -> a
360clampBounds (lower, upper) x
361  | x <= lower = lower
362  | x >  upper = upper
363  | otherwise  = x
364