File: FilterDialog.hs

package info (click to toggle)
bustle 0.7.4-1
  • links: PTS, VCS
  • area: main
  • in suites: buster
  • size: 720 kB
  • sloc: haskell: 3,938; ansic: 939; makefile: 110; sh: 8
file content (141 lines) | stat: -rw-r--r-- 4,963 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-
Bustle.UI.FilterDialog: allows the user to filter the displayed log
Copyright © 2011 Collabora Ltd.

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
-}
module Bustle.UI.FilterDialog
  ( runFilterDialog
  )
where

import Data.List (intercalate, groupBy, elemIndices)
import qualified Data.Set as Set
import Data.Set (Set)
import qualified Data.Function as F

import Graphics.UI.Gtk

import Bustle.Translation (__)
import Bustle.Types

namespace :: String
          -> (String, String)
namespace name = case reverse (elemIndices '.' name) of
    []    -> ("", name)
    (i:_) -> splitAt (i + 1) name

formatNames :: (UniqueName, Set OtherName)
            -> String
formatNames (u, os)
    | Set.null os = unUniqueName u
    | otherwise = intercalate "\n" . map (formatGroup . groupGroup) $ groups
  where
    groups = groupBy ((==) `F.on` fst) . map (namespace . unOtherName) $ Set.toAscList os

    groupGroup [] = error "unpossible empty group from groupBy"
    groupGroup xs@((ns, _):_) = (ns, map snd xs)

    formatGroup (ns, [y]) = ns ++ y
    formatGroup (ns, ys)  = ns ++ "{" ++ intercalate "," ys ++ "}"

type NameStore = ListStore (Bool, (UniqueName, Set OtherName))

makeStore :: [(UniqueName, Set OtherName)]
          -> Set UniqueName
          -> IO NameStore
makeStore names currentlyHidden =
    listStoreNew $ map toPair names
  where
    toPair name@(u, _) = (not (Set.member u currentlyHidden), name)

makeView :: NameStore
         -> IO ScrolledWindow
makeView nameStore = do
    nameView <- treeViewNewWithModel nameStore
    -- We want rules because otherwise it's tough to see where each group
    -- starts and ends
    treeViewSetRulesHint nameView True
    treeViewSetHeadersVisible nameView False
    widgetSetSizeRequest nameView 600 371

    tickyCell <- cellRendererToggleNew
    tickyColumn <- treeViewColumnNew
    treeViewColumnPackStart tickyColumn tickyCell True
    treeViewAppendColumn nameView tickyColumn

    cellLayoutSetAttributes tickyColumn tickyCell nameStore $ \(ticked, _) ->
        [ cellToggleActive := ticked ]

    on tickyCell cellToggled $ \pathstr -> do
        let [i] = stringToTreePath pathstr
        (v, ns) <- listStoreGetValue nameStore i
        listStoreSetValue nameStore i (not v, ns)

    nameCell <- cellRendererTextNew
    nameColumn <- treeViewColumnNew
    treeViewColumnPackStart nameColumn nameCell True
    treeViewAppendColumn nameView nameColumn

    cellLayoutSetAttributes nameColumn nameCell nameStore $ \(_, ns) ->
        [ cellText := formatNames ns ]

    sw <- scrolledWindowNew Nothing Nothing
    scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic
    containerAdd sw nameView

    return sw

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
    d <- dialogNew
    (windowWidth, windowHeight) <- windowGetSize parent
    windowSetDefaultSize d (windowWidth * 7 `div` 8) (windowHeight `div` 2)
    d `set` [ windowTransientFor := parent ]
    dialogAddButton d stockClose ResponseClose
    vbox <- castToBox <$> dialogGetContentArea d
    boxSetSpacing vbox 6

    nameStore <- makeStore names currentlyHidden
    sw <- makeView nameStore

    instructions <- labelNew (Nothing :: Maybe String)
    widgetSetSizeRequest instructions 600 (-1)
    labelSetMarkup instructions
        (__ "Unticking a service hides its column in the diagram, \
        \and all messages it is involved in. That is, all methods it calls \
        \or are called on it, the corresponding returns, and all signals it \
        \emits will be hidden.")
    labelSetLineWrap instructions True
    boxPackStart vbox instructions PackNatural 0

    boxPackStart vbox sw PackGrow 0
    widgetShowAll vbox

    _ <- dialogRun d

    widgetDestroy d

    results <- listStoreToList nameStore
    return $ Set.fromList [ u
                          | (ticked, (u, _)) <- results
                          , not ticked
                          ]