diff --git a/Bustle/Application/Monad.hs b/Bustle/Application/Monad.hs
--- a/Bustle/Application/Monad.hs
+++ b/Bustle/Application/Monad.hs
@@ -31,6 +31,7 @@
)
where
+import Control.Applicative
import Control.Monad.Reader
import Control.Monad.State
@@ -55,7 +56,7 @@
- embedIO $ onDance x . makeCallback dancedCB
-}
newtype Bustle config state a = B (ReaderT (BustleEnv config state) IO a)
- deriving (Functor, Monad, MonadIO)
+ deriving (Functor, Applicative, Monad, MonadIO)
newtype BustleEnv config state =
BustleEnv { unBustleEnv :: (config, IORef state) }
diff --git a/Bustle/Gtk.hs b/Bustle/Gtk.hs
new file mode 100644
--- /dev/null
+++ b/Bustle/Gtk.hs
@@ -0,0 +1,54 @@
+{-
+Bustle.Gtk: Stuff missing from the Gtk binding
+Copyright © 2015 Will Thompson
+
+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
+-}
+{-# LANGUAGE ForeignFunctionInterface #-}
+module Bustle.Gtk
+ ( b_windowSetTitlebar
+ , b_headerBarSetSubtitle
+ )
+where
+
+import Foreign.Ptr
+import Foreign.ForeignPtr
+
+import qualified System.Glib.GObject as GO
+import System.Glib.Properties (objectSetPropertyMaybeString)
+import Graphics.UI.Gtk
+
+
+foreign import ccall "gtk_window_set_titlebar"
+ gtk_window_set_titlebar :: Ptr GObject
+ -> Ptr GObject
+ -> IO ()
+
+
+b_windowSetTitlebar :: (WindowClass window,
+ WidgetClass widget)
+ => window
+ -> widget
+ -> IO ()
+b_windowSetTitlebar window titlebar =
+ withForeignPtr (GO.unGObject (GO.toGObject window)) $ \pWindow ->
+ withForeignPtr (GO.unGObject (GO.toGObject titlebar)) $ \pTitlebar ->
+ gtk_window_set_titlebar pWindow pTitlebar
+
+b_headerBarSetSubtitle :: WidgetClass headerBar -- BZZT
+ => headerBar
+ -> Maybe String
+ -> IO ()
+b_headerBarSetSubtitle = objectSetPropertyMaybeString "subtitle"
diff --git a/Bustle/Loader.hs b/Bustle/Loader.hs
--- a/Bustle/Loader.hs
+++ b/Bustle/Loader.hs
@@ -26,7 +26,7 @@
where
import Control.Exception
-import Control.Monad.Error
+import Control.Monad.Except
import Control.Arrow ((***))
import Text.Printf
@@ -39,15 +39,13 @@
import Bustle.Util (io)
data LoadError = LoadError FilePath String
-instance Error LoadError where
- strMsg = LoadError ""
-- this nested case stuff is ugly, but it's less ugly than it looked with
-- combinators to turn IO (Either a b) into ErrorT LoadError IO b using various
-- a -> LoadError functions.
readLog :: MonadIO io
=> FilePath
- -> ErrorT LoadError io ([String], Log)
+ -> ExceptT LoadError io ([String], Log)
readLog f = do
pcapResult <- io $ Pcap.readPcap f
liftM (id *** filter (isRelevant . deEvent)) $ case pcapResult of
diff --git a/Bustle/Loader/OldSkool.hs b/Bustle/Loader/OldSkool.hs
--- a/Bustle/Loader/OldSkool.hs
+++ b/Bustle/Loader/OldSkool.hs
@@ -29,16 +29,8 @@
import Data.Map (Map)
import Data.Maybe (isJust)
import qualified Data.Map as Map
-import Control.Monad (ap, when, guard)
-import Control.Applicative ((<$>))
-
-infixl 4 <*
-(<*) :: Monad m => m a -> m b -> m a
-m <* n = do ret <- m; n; return ret
-
-infixl 4 <*>
-(<*>) :: Monad m => m (a -> b) -> m a -> m b
-(<*>) = ap
+import Control.Monad (when, guard)
+import Control.Applicative ((<$>), (<*>), (<*))
type Parser a = GenParser Char (Map (TaggedBusName, Serial) (Detailed Message)) a
diff --git a/Bustle/Noninteractive.hs b/Bustle/Noninteractive.hs
--- a/Bustle/Noninteractive.hs
+++ b/Bustle/Noninteractive.hs
@@ -29,7 +29,7 @@
import System.IO (hPutStrLn, stderr)
import Data.Maybe (mapMaybe)
import Data.List (nub)
-import Control.Monad.Error
+import Control.Monad.Except
import Text.Printf
import Bustle.Loader
@@ -42,7 +42,7 @@
process :: FilePath -> (Log -> [a]) -> (a -> String) -> IO ()
process filepath analyze format = do
- ret <- runErrorT $ readLog filepath
+ ret <- runExceptT $ readLog filepath
case ret of
Left (LoadError _ err) -> do
warn $ printf (__ "Couldn't parse '%s': %s") filepath err
diff --git a/Bustle/Renderer.hs b/Bustle/Renderer.hs
--- a/Bustle/Renderer.hs
+++ b/Bustle/Renderer.hs
@@ -50,7 +50,7 @@
import Control.Applicative (Applicative(..), (<$>), (<*>))
import Control.Arrow ((***))
-import Control.Monad.Error
+import Control.Monad.Except
import Control.Monad.Identity
import Control.Monad.State
import Control.Monad.Writer
diff --git a/Bustle/UI.hs b/Bustle/UI.hs
--- a/Bustle/UI.hs
+++ b/Bustle/UI.hs
@@ -24,7 +24,7 @@
import Control.Monad.Reader
import Control.Monad.State
-import Control.Monad.Error
+import Control.Monad.Except
import Data.IORef
import qualified Data.Set as Set
@@ -38,6 +38,7 @@
import Bustle.Renderer
import Bustle.Types
import Bustle.Diagram
+import Bustle.Gtk (b_windowSetTitlebar, b_headerBarSetSubtitle)
import Bustle.Marquee (toString)
import Bustle.Util
import Bustle.UI.AboutDialog
@@ -62,7 +63,7 @@
, dropExtension, dropTrailingPathSeparator
, (), (<.>)
)
-import System.Directory (renameFile)
+import System.GIO.File.File (fileFromParseName, fileMove, FileCopyFlags(..))
type B a = Bustle BConfig BState a
@@ -80,8 +81,9 @@
data WindowInfo =
WindowInfo { wiWindow :: Window
- , wiSave :: ImageMenuItem
- , wiExport :: MenuItem
+ , wiHeaderBar :: Widget -- TODO
+ , wiSave :: Button
+ , wiExport :: Button
, wiViewStatistics :: CheckMenuItem
, wiFilterNames :: MenuItem
, wiNotebook :: Notebook
@@ -171,9 +173,9 @@
openLog :: MonadIO io
=> LogDetails
- -> ErrorT LoadError io ( ([String], [DetailedEvent])
- , ([String], [DetailedEvent])
- )
+ -> ExceptT LoadError io ( ([String], [DetailedEvent])
+ , ([String], [DetailedEvent])
+ )
openLog (RecordedLog filepath) = do
result <- readLog filepath
return (result, ([], []))
@@ -189,7 +191,7 @@
-> LogDetails
-> B ()
loadLogWith getWindow logDetails = do
- ret <- runErrorT $ do
+ ret <- runExceptT $ do
((sessionWarnings, sessionMessages),
(systemWarnings, systemMessages)) <- openLog logDetails
@@ -235,6 +237,13 @@
canvasScrollToBottom (wiCanvas wi)
setPage wi CanvasPage
+onMenuItemActivate :: MenuItemClass menuItem
+ => menuItem
+ -> IO ()
+ -> IO (ConnectId menuItem)
+onMenuItemActivate mi act =
+ on mi menuItemActivate act
+
finishedRecording :: WindowInfo
-> FilePath
-> Bool
@@ -250,7 +259,7 @@
io $ do
widgetSetSensitivity saveItem True
- onActivateLeaf saveItem $ showSaveDialog wi (return ())
+ saveItem `on` buttonActivated $ showSaveDialog wi (return ())
return ()
else do
setPage wi InstructionsPage
@@ -266,7 +275,22 @@
tempFileName = takeFileName tempFilePath
recorderChooseFile tempFileName mwindow $ \newFilePath -> do
- renameFile tempFilePath newFilePath
+ let tempFile = fileFromParseName tempFilePath
+ let newFile = fileFromParseName newFilePath
+
+ C.catch (fileMove tempFile newFile [FileCopyOverwrite] Nothing Nothing) $ \(GError _ _ msg) -> do
+ d <- messageDialogNew mwindow [DialogModal] MessageError ButtonsOk (__ "Couldn't save log")
+ let secondary :: String
+ secondary = printf
+ (__ "Error: %s\n\n\
+ \You might want to manually recover the log from the temporary file at\n\
+ \%s") (toString msg) tempFilePath
+ messageDialogSetSecondaryMarkup d secondary
+ widgetShowAll d
+ d `after` response $ \_ -> do
+ widgetDestroy d
+ return ()
+
widgetSetSensitivity (wiSave wi) False
wiSetLogDetails wi (SingleLog newFilePath)
savedCb
@@ -295,7 +319,7 @@
dialogAddButton prompt stockSave ResponseYes
widgetShowAll prompt
- prompt `afterResponse` \resp -> do
+ prompt `after` response $ \resp -> do
let closeUp = widgetDestroy (wiWindow wi)
case resp of
ResponseYes -> showSaveDialog wi closeUp
@@ -320,15 +344,17 @@
let getW cast name = io $ builderGetObject builder cast name
window <- getW castToWindow "diagramWindow"
- [newItem, openItem, saveItem, closeItem, aboutItem] <-
- mapM (getW castToImageMenuItem)
- ["new", "open", "save", "close", "about"]
- [newButton, openButton] <- mapM (getW castToButton) ["newButton", "openButton"]
- exportItem <- getW castToMenuItem "export"
- openTwoItem <- getW castToMenuItem "openTwo"
+ header <- getW castToWidget "header"
+
+ io $ b_windowSetTitlebar window header
+ [openItem, openTwoItem] <- mapM (getW castToMenuItem) ["open", "openTwo"]
+ [headerNew, headerSave, headerExport] <- mapM (getW castToButton) ["headerNew", "headerSave", "headerExport"]
+
viewStatistics <- getW castToCheckMenuItem "statistics"
filterNames <- getW castToMenuItem "filter"
+ aboutItem <- getW castToMenuItem "about"
+ [newButton, openButton] <- mapM (getW castToButton) ["newButton", "openButton"]
[nb, statsBook] <- mapM (getW castToNotebook)
["diagramOrNot", "statsBook"]
@@ -336,26 +362,29 @@
-- Open two logs dialog
openTwoDialog <- embedIO $ \r ->
- setupOpenTwoDialog builder window $ \f1 f2 ->
+ setupOpenTwoDialog window $ \f1 f2 ->
makeCallback (loadInInitialWindow (TwoLogs f1 f2)) r
-- Set up the window itself
- embedIO $ onDestroy window . makeCallback maybeQuit
+ embedIO $ (window `on` objectDestroy) . makeCallback maybeQuit
-- File menu and related buttons
embedIO $ \r -> do
let new = makeCallback startRecording r
- onActivateLeaf newItem new
- onClicked newButton new
+ forM [headerNew, newButton] $ \button ->
+ button `on` buttonActivated $ new
- let open = makeCallback (openDialogue window) r
- onActivateLeaf openItem open
- onClicked openButton open
+ let open = makeCallback openDialogue r
+ onMenuItemActivate openItem open
+ openButton `on` buttonActivated $ open
- onActivateLeaf openTwoItem $ widgetShowAll openTwoDialog
+ onMenuItemActivate openTwoItem $ widgetShowAll openTwoDialog
- -- Help menu
- io $ onActivateLeaf aboutItem $ showAboutDialog window
+ -- TODO: really this wants to live in the application menu, but that entails binding GApplication,
+ -- GtkApplication, GMenu, GActionMap, GActionEntry, ...
+ --
+ -- Similarly, the drop-down menus would look better as popovers. But here we are.
+ io $ onMenuItemActivate aboutItem $ showAboutDialog window
m <- asks methodIcon
s <- asks signalIcon
@@ -377,8 +406,9 @@
logDetailsRef <- io $ newIORef Nothing
let windowInfo = WindowInfo { wiWindow = window
- , wiSave = saveItem
- , wiExport = exportItem
+ , wiHeaderBar = header
+ , wiSave = headerSave
+ , wiExport = headerExport
, wiViewStatistics = viewStatistics
, wiFilterNames = filterNames
, wiNotebook = nb
@@ -391,9 +421,6 @@
}
io $ window `on` deleteEvent $ promptToSave windowInfo
- io $ closeItem `on` menuItemActivate $ do
- prompted <- promptToSave windowInfo
- when (not prompted) (widgetDestroy window)
incWindows
io $ widgetShow window
return windowInfo
@@ -422,30 +449,27 @@
canvasSetShapes canvas shapes regions (rrCentreOffset rr) windowWidth
-prettyDirectory :: String
- -> String
-prettyDirectory s = "(" ++ dropTrailingPathSeparator s ++ ")"
+splitFileName_ :: String
+ -> (String, String)
+splitFileName_ s = (dropTrailingPathSeparator d, f)
+ where
+ (d, f) = splitFileName s
logWindowTitle :: LogDetails
- -> String
-logWindowTitle (RecordedLog filepath) = "(*) " ++ takeFileName filepath
-logWindowTitle (SingleLog filepath) =
- intercalate " " [name, prettyDirectory directory]
+ -> (String, Maybe String)
+logWindowTitle (RecordedLog filepath) = ("*" ++ takeFileName filepath, Nothing)
+logWindowTitle (SingleLog filepath) = (name, Just directory)
where
- (directory, name) = splitFileName filepath
+ (directory, name) = splitFileName_ filepath
logWindowTitle (TwoLogs sessionPath systemPath) =
- intercalate " " $ filter (not . null)
- [ sessionName, sessionDirectory'
- , "&"
- , systemName, prettyDirectory systemDirectory
- ]
+ -- TODO: this looks terrible, need a custom widget
+ (sessionName ++ " & " ++ systemName,
+ Just $ if sessionDirectory == systemDirectory
+ then sessionDirectory
+ else sessionDirectory ++ " & " ++ systemDirectory)
where
- (sessionDirectory, sessionName) = splitFileName sessionPath
- (systemDirectory, systemName ) = splitFileName systemPath
- sessionDirectory' =
- if sessionDirectory == systemDirectory
- then ""
- else prettyDirectory sessionDirectory
+ (sessionDirectory, sessionName) = splitFileName_ sessionPath
+ (systemDirectory, systemName ) = splitFileName_ systemPath
logTitle :: LogDetails
-> String
@@ -460,8 +484,9 @@
-> IO ()
wiSetLogDetails wi logDetails = do
writeIORef (wiLogDetails wi) (Just logDetails)
- windowSetTitle (wiWindow wi)
- (printf (__ "%s - Bustle") (logWindowTitle logDetails) :: String)
+ let (title, subtitle) = logWindowTitle logDetails
+ (wiWindow wi) `set` [ windowTitle := title ]
+ b_headerBarSetSubtitle (wiHeaderBar wi) subtitle
setPage :: MonadIO io
=> WindowInfo
@@ -495,7 +520,7 @@
updateDisplayedLog wi rr
widgetSetSensitivity exportItem True
- onActivateLeaf exportItem $ do
+ exportItem `on` buttonActivated $ do
shapes <- canvasGetShapes canvas
saveToPDFDialogue wi shapes
@@ -513,7 +538,7 @@
else widgetHide statsBook
widgetSetSensitivity filterNames True
- onActivateLeaf filterNames $ do
+ onMenuItemActivate filterNames $ do
hidden <- readIORef hiddenRef
hidden' <- runFilterDialog window (sessionParticipants $ rrApplications rr) hidden
writeIORef hiddenRef hidden'
@@ -529,17 +554,16 @@
C.catch (fmap Just (pixbufNewFromFile iconName))
(\(GError _ _ msg) -> warn (toString msg) >> return Nothing)
-openDialogue :: Window -> B ()
-openDialogue window = embedIO $ \r -> do
- chooser <- fileChooserDialogNew Nothing (Just window) FileChooserActionOpen
+openDialogue :: B ()
+openDialogue = embedIO $ \r -> do
+ chooser <- fileChooserDialogNew Nothing Nothing FileChooserActionOpen
[ ("gtk-cancel", ResponseCancel)
, ("gtk-open", ResponseAccept)
]
- chooser `set` [ windowModal := True
- , fileChooserLocalOnly := True
+ chooser `set` [ fileChooserLocalOnly := True
]
- chooser `afterResponse` \resp -> do
+ chooser `after` response $ \resp -> do
when (resp == ResponseAccept) $ do
Just fn <- fileChooserGetFilename chooser
makeCallback (loadInInitialWindow (SingleLog fn)) r
@@ -574,7 +598,7 @@
TwoLogs p _ -> Just $ takeDirectory p
maybeM mdirectory $ fileChooserSetCurrentFolder chooser
- chooser `afterResponse` \resp -> do
+ chooser `after` response $ \resp -> do
when (resp == ResponseAccept) $ do
Just fn <- io $ fileChooserGetFilename chooser
let (width, height) = diagramDimensions shapes
diff --git a/Bustle/UI/AboutDialog.hs b/Bustle/UI/AboutDialog.hs
--- a/Bustle/UI/AboutDialog.hs
+++ b/Bustle/UI/AboutDialog.hs
@@ -50,12 +50,12 @@
, aboutDialogAuthors := authors
, aboutDialogCopyright := "© 2008–2014 Will Thompson, Collabora Ltd. and contributors"
, aboutDialogLicense := license
+ , aboutDialogLogoIconName := Just "bustle"
+ , windowModal := True
+ , windowTransientFor := window
]
- dialog `afterResponse` \resp ->
+ dialog `after` response $ \resp ->
when (resp == ResponseCancel) (widgetDestroy dialog)
- windowSetTransientFor dialog window
- windowSetModal dialog True
- aboutDialogSetLogoIconName dialog (Just "bustle")
widgetShowAll dialog
diff --git a/Bustle/UI/Canvas.hs b/Bustle/UI/Canvas.hs
--- a/Bustle/UI/Canvas.hs
+++ b/Bustle/UI/Canvas.hs
@@ -35,6 +35,7 @@
import Control.Monad (when)
import Graphics.UI.Gtk
+import Graphics.Rendering.Cairo (Render, translate)
import Bustle.Diagram
import Bustle.Regions
@@ -131,11 +132,7 @@
"End" -> updateWith regionSelectionLast
_ -> stopEvent
- -- Expose events
- -- I think we could speed things up by only showing the revealed area
- -- rather than everything that's visible.
- layout `on` exposeEvent $ tryEvent $ io $ canvasUpdate canvas
-
+ layout `on` draw $ canvasDraw canvas
return ()
canvasInvalidateArea :: Canvas a
@@ -257,30 +254,30 @@
canvasGetShapes = readIORef . canvasShapes
-- | Redraws the currently-visible area of the canvas
-canvasUpdate :: Canvas a
- -> IO ()
-canvasUpdate canvas = do
- current <- canvasGetSelection canvas
- shapes <- canvasGetShapes canvas
- width <- readIORef $ canvasWidth canvas
+canvasDraw :: Canvas a
+ -> Render ()
+canvasDraw canvas = do
+ current <- io $ canvasGetSelection canvas
+ shapes <- io $ canvasGetShapes canvas
+ width <- io $ readIORef $ canvasWidth canvas
let shapes' = case current of
Nothing -> shapes
Just (Stripe y1 y2, _) -> Highlight (0, y1, width, y2):shapes
let layout = canvasLayout canvas
- hadj <- layoutGetHAdjustment layout
- hpos <- adjustmentGetValue hadj
- hpage <- adjustmentGetPageSize hadj
+ hadj <- io $ layoutGetHAdjustment layout
+ hpos <- io $ adjustmentGetValue hadj
+ hpage <- io $ adjustmentGetPageSize hadj
- vadj <- layoutGetVAdjustment layout
- vpos <- adjustmentGetValue vadj
- vpage <- adjustmentGetPageSize vadj
+ vadj <- io $ layoutGetVAdjustment layout
+ vpos <- io $ adjustmentGetValue vadj
+ vpage <- io $ adjustmentGetPageSize vadj
let r = (hpos, vpos, hpos + hpage, vpos + vpage)
- win <- layoutGetDrawWindow layout
- renderWithDrawable win $ drawRegion r (canvasShowBounds canvas) shapes'
+ translate (-hpos) (-vpos)
+ drawRegion r (canvasShowBounds canvas) shapes'
canvasFocus :: Canvas a
-> IO ()
diff --git a/Bustle/UI/FilterDialog.hs b/Bustle/UI/FilterDialog.hs
--- a/Bustle/UI/FilterDialog.hs
+++ b/Bustle/UI/FilterDialog.hs
@@ -22,21 +22,36 @@
)
where
-import Data.List (intercalate)
+import Data.List (intercalate, groupBy, findIndices)
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 (findIndices (== '.') 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 unOtherName $ Set.toAscList os
+ | 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)]
@@ -91,9 +106,11 @@
-> IO (Set UniqueName) -- ^ The set of names to *hide*
runFilterDialog parent names currentlyHidden = do
d <- dialogNew
- windowSetTransientFor d parent
+ (windowWidth, windowHeight) <- windowGetSize parent
+ windowSetDefaultSize d (windowWidth * 7 `div` 8) (windowHeight `div` 2)
+ d `set` [ windowTransientFor := parent ]
dialogAddButton d stockClose ResponseClose
- vbox <- dialogGetUpper d
+ vbox <- fmap castToBox $ dialogGetContentArea d
boxSetSpacing vbox 6
nameStore <- makeStore names currentlyHidden
@@ -109,7 +126,7 @@
labelSetLineWrap instructions True
boxPackStart vbox instructions PackNatural 0
- containerAdd vbox sw
+ boxPackStart vbox sw PackGrow 0
widgetShowAll vbox
_ <- dialogRun d
diff --git a/Bustle/UI/OpenTwoDialog.hs b/Bustle/UI/OpenTwoDialog.hs
--- a/Bustle/UI/OpenTwoDialog.hs
+++ b/Bustle/UI/OpenTwoDialog.hs
@@ -28,6 +28,7 @@
import Graphics.UI.Gtk
import Bustle.Util
+import Paths_bustle
-- Propagates changes to d1's currently-selected folder to d2, if and only if
-- d2 doesn't have a currently-selected file (otherwise, choosing a file
@@ -37,7 +38,7 @@
=> chooser
-> chooser
-> IO (ConnectId chooser)
-propagateCurrentFolder d1 d2 = d1 `onCurrentFolderChanged` do
+propagateCurrentFolder d1 d2 = d1 `on` currentFolderChanged $ do
f1 <- fileChooserGetCurrentFolder d1
f2 <- fileChooserGetCurrentFolder d2
otherFile <- fileChooserGetFilename d2
@@ -48,25 +49,27 @@
fileChooserSetCurrentFolder d2 (fromJust f1)
return ()
-setupOpenTwoDialog :: Builder
- -> Window
+setupOpenTwoDialog :: Window
-> (FilePath -> FilePath -> IO ())
-> IO Dialog
-setupOpenTwoDialog builder parent callback = do
+setupOpenTwoDialog parent callback = do
+ builder <- builderNew
+ builderAddFromFile builder =<< getDataFileName "data/OpenTwoDialog.ui"
+
dialog <- builderGetObject builder castToDialog "openTwoDialog"
[sessionBusChooser, systemBusChooser] <-
mapM (builderGetObject builder castToFileChooserButton)
["sessionBusChooser", "systemBusChooser"]
openTwoOpenButton <- builderGetObject builder castToButton "openTwoOpenButton"
- windowSetTransientFor dialog parent
+ dialog `set` [ windowTransientFor := parent ]
dialog `on` deleteEvent $ tryEvent $ io $ widgetHide dialog
propagateCurrentFolder sessionBusChooser systemBusChooser
propagateCurrentFolder systemBusChooser sessionBusChooser
let hideMyself = do
- widgetHideAll dialog
+ widgetHide dialog
fileChooserUnselectAll sessionBusChooser
fileChooserUnselectAll systemBusChooser
@@ -82,7 +85,7 @@
connectGeneric "file-set" False systemBusChooser updateOpenSensitivity
updateOpenSensitivity
- dialog `afterResponse` \resp -> do
+ dialog `after` response $ \resp -> do
when (resp == ResponseAccept) $ do
Just f1 <- fileChooserGetFilename sessionBusChooser
Just f2 <- fileChooserGetFilename systemBusChooser
diff --git a/Bustle/UI/Recorder.hs b/Bustle/UI/Recorder.hs
--- a/Bustle/UI/Recorder.hs
+++ b/Bustle/UI/Recorder.hs
@@ -27,6 +27,7 @@
import Control.Concurrent.MVar
import qualified Data.Map as Map
import Data.Monoid
+import Data.Maybe (maybeToList)
import Control.Monad.State (runStateT)
import Text.Printf
@@ -95,9 +96,12 @@
monitor <- monitorNew BusTypeSession filename
dialog <- dialogNew
- maybe (return ()) (windowSetTransientFor dialog) mwindow
- dialog `set` [ windowModal := True ]
+ dialog `set` (map (windowTransientFor :=) (maybeToList mwindow))
+ dialog `set` [ windowModal := True
+ , windowTitle := ""
+ ]
+
label <- labelNew (Nothing :: Maybe String)
labelSetMarkup label $
(printf (__ "Logged %u messages…") (0 :: Int) :: String)
@@ -121,19 +125,21 @@
processor <- processBatch pendingRef n label incoming
processorId <- timeoutAdd processor 200
- bar <- progressBarNew
- pulseId <- timeoutAdd (progressBarPulse bar >> return True) 100
+ spinner <- spinnerNew
+ spinnerStart spinner
- vbox <- dialogGetUpper dialog
- boxPackStart vbox label PackGrow 0
- boxPackStart vbox bar PackNatural 0
+ vbox <- fmap castToBox $ dialogGetContentArea dialog
+ hbox <- hBoxNew False 8
+ boxPackStart hbox spinner PackNatural 0
+ boxPackStart hbox label PackGrow 0
+ boxPackStart vbox hbox PackGrow 0
dialogAddButton dialog "gtk-media-stop" ResponseClose
- dialog `afterResponse` \_ -> do
+ dialog `after` response $ \_ -> do
monitorStop monitor
signalDisconnect handlerId
- timeoutRemove pulseId
+ spinnerStop spinner
timeoutRemove processorId
-- Flush out any last messages from the queue.
processor
@@ -161,7 +167,7 @@
, fileChooserDoOverwriteConfirmation := True
]
- chooser `afterResponse` \resp -> do
+ chooser `after` response $ \resp -> do
when (resp == ResponseAccept) $ do
Just fn <- fileChooserGetFilename chooser
callback fn
diff --git a/Bustle/UI/Util.hs b/Bustle/UI/Util.hs
--- a/Bustle/UI/Util.hs
+++ b/Bustle/UI/Util.hs
@@ -41,5 +41,5 @@
maybeM mbody $ messageDialogSetSecondaryText dialog
- dialog `afterResponse` \_ -> widgetDestroy dialog
+ dialog `after` response $ \_ -> widgetDestroy dialog
widgetShowAll dialog
diff --git a/Bustle/VariantFormatter.hs b/Bustle/VariantFormatter.hs
--- a/Bustle/VariantFormatter.hs
+++ b/Bustle/VariantFormatter.hs
@@ -110,6 +110,7 @@
typeCode TypeString = "s"
typeCode TypeSignature = "g"
typeCode TypeObjectPath = "o"
+typeCode TypeUnixFd = "h"
typeCode TypeVariant = "v"
typeCode (TypeArray t) = 'a':typeCode t
typeCode (TypeDictionary kt vt) = concat [ "a{", typeCode kt , typeCode vt, "}"]
@@ -137,6 +138,7 @@
TypeString -> format_String . fromJust . fromVariant
TypeSignature -> format_Signature . fromJust . fromVariant
TypeObjectPath -> format_ObjectPath . fromJust . fromVariant
+ TypeUnixFd -> const ""
TypeVariant -> format_Variant VariantStyleAngleBrackets . fromJust . fromVariant
TypeArray TypeWord8 -> format_ByteArray . fromJust . fromVariant
TypeArray _ -> format_Array . fromJust . fromVariant
diff --git a/Makefile b/Makefile
--- a/Makefile
+++ b/Makefile
@@ -29,7 +29,7 @@
BUSTLE_PCAP_HEADERS = c-sources/pcap-monitor.h $(BUSTLE_PCAP_GENERATED_HEADERS)
bustle-pcap.1: dist/build/bustle-pcap
- -help2man --output=$@ --no-info --name='Generate D-Bus logs for bustle' $<
+ help2man --output=$@ --no-info --name='Generate D-Bus logs for bustle' $<
bustle.desktop: data/bustle.desktop.in
LC_ALL=C intltool-merge -d -u po $< $@
@@ -97,7 +97,7 @@
TARBALL := $(TARBALL_DIR).tar.bz2
maintainer-binary-tarball: all
mkdir -p $(TARBALL_FULL_DIR)
- cabal-dev install --prefix=$(TOP)/$(TARBALL_FULL_DIR) \
+ cabal install --prefix=$(TOP)/$(TARBALL_FULL_DIR) \
--datadir=$(TOP)/$(TARBALL_FULL_DIR) --datasubdir=.
cp bustle.sh README.md $(TARBALL_FULL_DIR)
perl -pi -e 's{^ bustle-pcap}{ ./bustle-pcap};' \
diff --git a/NEWS.md b/NEWS.md
--- a/NEWS.md
+++ b/NEWS.md
@@ -1,3 +1,12 @@
+Bustle 0.5.0 (2015-06-04)
+-------------------------
+
+* Use Gtk+ 3, making Bustle more beautiful and support hidpi displays.
+* Fix warnings triggered by recent GHCs and standard libraries by
+ completely mechanical patching.
+* Try not to crash if you view the body of a message containing a Unix
+ FD.
+
Bustle 0.4.8 (2015-03-22)
-------------------------
diff --git a/Test/Regions.hs b/Test/Regions.hs
--- a/Test/Regions.hs
+++ b/Test/Regions.hs
@@ -171,6 +171,9 @@
withRegions vr $ \rs -> property $
regionSelectionNew (regionSelectionFlatten rs) == rs
+-- Essential scary hack to make quickCheckAll work O_o
+-- https://hackage.haskell.org/package/QuickCheck-2.7.6/docs/Test-QuickCheck-All.html
+return []
runTests = $quickCheckAll
main = do
diff --git a/bustle.cabal b/bustle.cabal
--- a/bustle.cabal
+++ b/bustle.cabal
@@ -1,6 +1,6 @@
Name: bustle
Category: Network, Desktop
-Version: 0.4.8
+Version: 0.5.0
Cabal-Version: >= 1.8
Synopsis: Draw sequence diagrams of D-Bus traffic
Description: Draw sequence diagrams of D-Bus traffic
@@ -11,6 +11,7 @@
Data-files: data/dfeet-method.png,
data/dfeet-signal.png,
data/bustle.ui,
+ data/OpenTwoDialog.ui,
LICENSE
Build-type: Custom
Extra-source-files:
@@ -69,6 +70,7 @@
Main-is: Bustle.hs
Other-modules: Bustle.Application.Monad
, Bustle.Diagram
+ , Bustle.Gtk
, Bustle.Loader
, Bustle.Loader.OldSkool
, Bustle.Loader.Pcap
@@ -107,7 +109,8 @@
, directory
, filepath
, glib
- , gtk >= 0.12.4
+ , gio
+ , gtk3
, hgettext >= 0.1.5
, mtl
, pango
@@ -137,7 +140,8 @@
, dbus
, directory
, filepath
- , gtk > 0.12
+ -- 0.13.6 doesn't compile with GCC 5: https://github.com/gtk2hs/gtk2hs/issues/104
+ , gtk3 >= 0.13.7
, glib
, hgettext
, mtl
@@ -191,7 +195,7 @@
, dbus >= 0.10
, directory
, filepath
- , gtk
+ , gtk3
, mtl
, text
, pango
diff --git a/data/OpenTwoDialog.ui b/data/OpenTwoDialog.ui
new file mode 100644
--- /dev/null
+++ b/data/OpenTwoDialog.ui
@@ -0,0 +1,133 @@
+
+
+
+
+
diff --git a/data/bustle.ui b/data/bustle.ui
--- a/data/bustle.ui
+++ b/data/bustle.ui
@@ -12,168 +12,6 @@
True
False
-
-
- False
- True
- 0
-
-
-
-