Commit 91d6bbd8 authored by Will Thompson's avatar Will Thompson

Support "positive" filtering

Previously, the filtering mechanism was “hide all messages which involve
one of these names”, although the dialog presented them in the opposite
sense. I often want to say something a bit different: “show only
messages which involve one of these names”.

Implement this with three states for each name: Default, Only, and
Never. The logic for each message is:

 * If it involves at least one Never name, hide it
 * If there are no Only names, show it
 * Otherwise, show it if it involves at least one Only name
parent d784145f
......@@ -142,8 +142,8 @@ instance Semigroup apps => Semigroup (RendererResult apps) where
instance Monoid apps => Monoid (RendererResult apps) where
mempty = RendererResult 0 0 [] [] mempty []
processWithFilters :: (Log, Set UniqueName)
-> (Log, Set UniqueName)
processWithFilters :: (Log, NameFilter)
-> (Log, NameFilter)
-> RendererResult ()
processWithFilters (sessionBusLog, sessionFilter)
(systemBusLog, systemFilter ) =
......@@ -159,7 +159,7 @@ process sessionBusLog systemBusLog =
-- Doesn't let you filter
rendererStateNew :: RendererState
rendererStateNew = initialState Set.empty Set.empty
rendererStateNew = initialState emptyNameFilter emptyNameFilter
buildResult :: RendererOutput
-> RendererState
......@@ -243,7 +243,7 @@ data BusState =
, nextColumn :: Double
, columnsInUse :: Set Double
, pending :: Pending
, bsIgnoredNames :: Set UniqueName
, bsFilter :: NameFilter
}
data RendererState =
......@@ -254,7 +254,7 @@ data RendererState =
, startTime :: Microseconds
}
initialBusState :: Set UniqueName
initialBusState :: NameFilter
-> Double
-> BusState
initialBusState ignore x =
......@@ -263,17 +263,17 @@ initialBusState ignore x =
, nextColumn = x
, columnsInUse = Set.empty
, pending = Map.empty
, bsIgnoredNames = ignore
, bsFilter = ignore
}
initialSessionBusState, initialSystemBusState :: Set UniqueName -> BusState
initialSessionBusState, initialSystemBusState :: NameFilter -> BusState
initialSessionBusState f =
initialBusState f $ timestampAndMemberWidth + firstColumnOffset
initialSystemBusState f =
initialBusState f $ negate firstColumnOffset
initialState :: Set UniqueName
-> Set UniqueName
initialState :: NameFilter
-> NameFilter
-> RendererState
initialState sessionFilter systemFilter = RendererState
{ sessionBusState = initialSessionBusState sessionFilter
......@@ -648,9 +648,12 @@ shouldShow :: Bus
-> Message
-> Renderer Bool
shouldShow bus m = do
ignored <- getsBusState bsIgnoredNames bus
nameFilter <- getsBusState bsFilter bus
names <- mapM (fmap fst . lookupApp bus) (mentionedNames m)
return $ Set.null (ignored `Set.intersection` Set.fromList names)
return $
not (any (flip Set.member $ nfNever nameFilter) names)
&& (Set.null (nfOnly nameFilter)
|| any (flip Set.member $ nfOnly nameFilter) names)
processOne :: Bus
-> Detailed Event
......
......@@ -38,6 +38,9 @@ module Bustle.Types
, unOtherName
, unBusName
, NameFilter(..)
, emptyNameFilter
, dbusName
, dbusInterface
......@@ -68,6 +71,8 @@ import DBus ( ObjectPath, formatObjectPath
)
import Data.Maybe (maybeToList)
import Data.Either (partitionEithers)
import Data.Set (Set)
import qualified Data.Set as Set
type Serial = Word32
......@@ -95,6 +100,14 @@ unBusName :: TaggedBusName -> String
unBusName (U (UniqueName x)) = formatBusName x
unBusName (O (OtherName x)) = formatBusName x
data NameFilter =
NameFilter { nfOnly :: Set UniqueName
, nfNever :: Set UniqueName
}
emptyNameFilter :: NameFilter
emptyNameFilter = NameFilter Set.empty Set.empty
-- These useful constants disappeared from dbus in the grand removing of the
-- -core suffix.
dbusName :: BusName
......
......@@ -30,7 +30,6 @@ import Control.Monad.Except
import Data.IORef
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.List (intercalate)
import Data.Time
import Data.Tuple (swap)
......@@ -672,7 +671,7 @@ displayLog wi@WindowInfo { wiWindow = window
rr = io $ void $ do
wiSetLogDetails wi logDetails
hiddenRef <- newIORef Set.empty
nameFilterRef <- newIORef emptyNameFilter
updateDisplayedLog wi rr
......@@ -698,10 +697,11 @@ displayLog wi@WindowInfo { wiWindow = window
widgetSetSensitivity filterNames True
onMenuItemActivate filterNames $ do
hidden <- readIORef hiddenRef
hidden' <- runFilterDialog window (sessionParticipants $ rrApplications rr) hidden
writeIORef hiddenRef hidden'
let rr' = processWithFilters (sessionMessages, hidden') (systemMessages, Set.empty)
nameFilter <- readIORef nameFilterRef
-- FIXME: also allow filtering system bus in two-bus case
nameFilter' <- runFilterDialog window (sessionParticipants $ rrApplications rr) nameFilter
writeIORef nameFilterRef nameFilter'
let rr' = processWithFilters (sessionMessages, nameFilter') (systemMessages, emptyNameFilter)
updateDisplayedLog wi rr'
......
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-
Bustle.UI.FilterDialog: allows the user to filter the displayed log
......@@ -24,20 +23,35 @@ module Bustle.UI.FilterDialog
)
where
import Data.List (intercalate, groupBy, elemIndices)
import Control.Monad (forM, forM_)
import Data.List (intercalate, groupBy, elemIndices, elemIndex)
import qualified Data.Set as Set
import Data.Set (Set)
import qualified Data.Function as F
import Graphics.UI.Gtk
import Graphics.UI.Gtk.ModelView.CellRendererCombo (cellComboTextModel)
import Bustle.Translation (__)
import Bustle.Types
import Paths_bustle
data NameVisibility = NameVisibilityDefault
| NameVisibilityOnly
| NameVisibilityNever
deriving (Show, Eq, Ord, Enum, Bounded)
nameVisibilityName :: NameVisibility
-> String
nameVisibilityName v = case v of
NameVisibilityDefault -> __ "Default"
NameVisibilityOnly -> __ "Only this"
NameVisibilityNever -> __ "Hidden"
data NameEntry = NameEntry { neUniqueName :: UniqueName
, neOtherNames :: Set OtherName
, neVisible :: Bool
, neVisibility :: NameVisibility
}
namespace :: String
......@@ -65,15 +79,26 @@ formatNames ne
type NameStore = ListStore NameEntry
makeStore :: [(UniqueName, Set OtherName)]
-> Set UniqueName
-> NameFilter
-> IO NameStore
makeStore names currentlyHidden =
makeStore names nameFilter =
listStoreNew $ map toNameEntry names
where
toNameEntry (u, os) = NameEntry { neUniqueName = u
, neOtherNames = os
, neVisible = not (Set.member u currentlyHidden)
, neVisibility = toVisibility u
}
toVisibility u | Set.member u (nfOnly nameFilter) = NameVisibilityOnly
| Set.member u (nfNever nameFilter) = NameVisibilityNever
| otherwise = NameVisibilityDefault
nameStoreUpdate :: NameStore
-> Int
-> (NameEntry -> NameEntry)
-> IO ()
nameStoreUpdate nameStore i f = do
ne <- listStoreGetValue nameStore i
listStoreSetValue nameStore i $ f ne
makeView :: NameStore
-> TreeView
......@@ -81,50 +106,99 @@ makeView :: NameStore
makeView nameStore nameView = do
treeViewSetModel nameView (Just nameStore)
tickyCell <- cellRendererToggleNew
tickyColumn <- treeViewColumnNew
treeViewColumnPackStart tickyColumn tickyCell True
treeViewAppendColumn nameView tickyColumn
cellLayoutSetAttributes tickyColumn tickyCell nameStore $ \ne ->
[ cellToggleActive := neVisible ne ]
on tickyCell cellToggled $ \pathstr -> do
let [i] = stringToTreePath pathstr
ne <- listStoreGetValue nameStore i
listStoreSetValue nameStore i (ne { neVisible = not (neVisible ne) })
-- Bus name column
nameCell <- cellRendererTextNew
nameColumn <- treeViewColumnNew
nameColumn `set` [ treeViewColumnTitle := __ "Bus Name"
, treeViewColumnExpand := True
]
treeViewColumnPackStart nameColumn nameCell True
treeViewAppendColumn nameView nameColumn
cellLayoutSetAttributes nameColumn nameCell nameStore $ \ne ->
[ cellText := formatNames ne ]
-- TreeStore of possible visibility states
let nameVisibilities = [minBound..]
let nameVisibilityNames = map nameVisibilityName nameVisibilities
visibilityModel <- listStoreNew nameVisibilityNames
let visibilityNameCol = makeColumnIdString 1
treeModelSetColumn visibilityModel visibilityNameCol id
-- Visibility column
comboCell <- cellRendererComboNew
comboCell `set` [ cellTextEditable := True
, cellComboHasEntry := False
]
comboColumn <- treeViewColumnNew
comboColumn `set` [ treeViewColumnTitle := __ "Visibility"
, treeViewColumnExpand := False
]
treeViewColumnPackStart comboColumn comboCell True
treeViewAppendColumn nameView comboColumn
cellLayoutSetAttributes comboColumn comboCell nameStore $ \ne ->
[ cellComboTextModel := (visibilityModel, visibilityNameCol)
, cellText :=> do
let Just j = elemIndex (neVisibility ne) nameVisibilities
listStoreGetValue visibilityModel j
]
comboCell `on` edited $ \[i] str -> do
let (Just j) = elemIndex str nameVisibilityNames
nameStoreUpdate nameStore i $ \ne ->
ne { neVisibility = nameVisibilities !! j }
return ()
runFilterDialog :: WindowClass parent
=> parent -- ^ The window to which to attach the dialog
-> [(UniqueName, Set OtherName)] -- ^ Names, in order of appearance
-> Set UniqueName -- ^ Currently-hidden names
-> IO (Set UniqueName) -- ^ The set of names to *hide*
runFilterDialog parent names currentlyHidden = do
-> NameFilter -- ^ Current filter
-> IO NameFilter -- ^ New filter
runFilterDialog parent names currentFilter = do
builder <- builderNew
builderAddFromFile builder =<< getDataFileName "data/FilterDialog.ui"
d <- builderGetObject builder castToDialog ("filterDialog" :: String)
(windowWidth, windowHeight) <- windowGetSize parent
windowSetDefaultSize d (windowWidth * 7 `div` 8) (windowHeight `div` 2)
(_, windowHeight) <- windowGetSize parent
windowSetDefaultSize d (-1) (windowHeight * 3 `div` 4)
d `set` [ windowTransientFor := parent ]
nameStore <- makeStore names currentlyHidden
nameStore <- makeStore names currentFilter
makeView nameStore =<< builderGetObject builder castToTreeView ("filterTreeView" :: String)
resetButton <- builderGetObject builder castToButton ("resetButton" :: String)
resetButton `on` buttonActivated $ do
n <- listStoreGetSize nameStore
forM_ [0..n-1] $ \i ->
nameStoreUpdate nameStore i $ \ne -> ne { neVisibility = NameVisibilityDefault }
-- TODO: live-update the filter, and hence the view...? This callback is
-- grossly inefficient because in the rowChanged case we know what changed;
-- and in the initial case we can just look at currentFilter
let updateResetSensitivity = do
n <- listStoreGetSize nameStore
nes <- forM [0..n-1] $ listStoreGetValue nameStore
let vs = map neVisibility nes
widgetSetSensitive resetButton $ any (/= NameVisibilityDefault) vs
updateResetSensitivity
nameStore `on` rowChanged $ \_path _iter -> updateResetSensitivity
_ <- dialogRun d
widgetDestroy d
results <- listStoreToList nameStore
return $ Set.fromList [ neUniqueName ne
| ne <- results
, not (neVisible ne)
]
let onlys = Set.fromList [ neUniqueName ne
| ne <- results
, neVisibility ne == NameVisibilityOnly
]
nevers = Set.fromList [ neUniqueName ne
| ne <- results
, neVisibility ne == NameVisibilityNever
]
return $ NameFilter { nfOnly = onlys
, nfNever = nevers
}
......@@ -13,7 +13,13 @@
<property name="has_subtitle">False</property>
<property name="show_close_button">True</property>
<child>
<placeholder/>
<object class="GtkButton" id="resetButton">
<property name="label" translatable="yes">_Reset</property>
<property name="visible">True</property>
<property name="can_focus">True</property>
<property name="receives_default">True</property>
<property name="use_underline">True</property>
</object>
</child>
</object>
</child>
......@@ -45,15 +51,13 @@
<property name="visible">True</property>
<property name="can_focus">True</property>
<property name="border_width">0</property>
<property name="vscrollbar_policy">always</property>
<property name="hscrollbar_policy">never</property>
<property name="shadow_type">in</property>
<child>
<object class="GtkTreeView" id="filterTreeView">
<property name="width_request">600</property>
<property name="height_request">371</property>
<property name="visible">True</property>
<property name="can_focus">True</property>
<property name="headers_visible">False</property>
<property name="headers_clickable">False</property>
<property name="rules_hint">True</property>
<child internal-child="selection">
<object class="GtkTreeSelection"/>
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment