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