wild-bind-indicator 0.2.0.0 → 1.0.0.0
raw patch · 3 files changed
+112/−73 lines, 3 filesdep +asyncdep +gi-gdkdep +gi-glibdep −gtkdep ~basedep ~containersPVP ok
version bump matches the API change (PVP)
Dependencies added: async, gi-gdk, gi-glib, gi-gtk
Dependencies removed: gtk
Dependency ranges changed: base, containers
API changes (from Hackage documentation)
Files
- ChangeLog.md +8/−1
- src/WildBind/Indicator.hs +96/−67
- wild-bind-indicator.cabal +8/−5
ChangeLog.md view
@@ -1,10 +1,17 @@ # Revision history for wild-bind-indicator +## 1.0.0.0 -- 2020-12-30++* **MAJOR CHANGE**: Now it uses `gi-gtk` package, instead of `gtk` package.+ Although this doesn't change the API of wild-bind-indicator, it changes the prerequisite packages/libraries significantly.+ Thus we bumped the major version.+* Now it uses `async` package to clean-up the WildBind action when the Gtk+ GUI finishes. Probably fixes #4 and #5a.+* Confirm build with `containers-0.6.0.1`+ ## 0.2.0.0 -- 2018-01-01 * Modify constraints of `withNumPadIndicator`, `wildBindWithIndicator`, `bindingHook` functions. * Add `adaptIndicator`, `toggleBinding` functions.- ## 0.1.0.1 -- 2016-09-22
src/WildBind/Indicator.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings, OverloadedLabels, PatternSynonyms #-} -- | -- Module: WildBind.Indicator -- Description: Graphical indicator for WildBind@@ -31,34 +31,20 @@ ) where import Control.Applicative ((<$>))-import Control.Concurrent (forkFinally, rtsSupportsBoundThreads)-import Control.Exception (throwIO)+import Control.Concurrent+ (rtsSupportsBoundThreads, newEmptyMVar, putMVar, takeMVar)+import Control.Concurrent.Async (withAsync)+import Control.Exception (throwIO, finally) import Control.Monad (void, forM_) import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Reader (ReaderT, runReaderT, ask) import Data.IORef (newIORef, readIORef) import qualified Data.Map as M import Data.Monoid (mconcat, First(First))-import Data.Text (Text)-import Graphics.UI.Gtk- ( initGUI, mainGUI, postGUIAsync, postGUISync, mainQuit,- Window, windowNew, windowSetKeepAbove, windowSkipPagerHint,- windowSkipTaskbarHint, windowAcceptFocus, windowFocusOnMap,- windowSetTitle, windowMove,- AttrOp((:=)),- widgetShowAll, widgetSetSizeRequest, widgetVisible, widgetHide,- Table, tableNew, tableAttachDefaults,- buttonNew, buttonSetAlignment,- Label, labelNew, labelSetLineWrap, labelSetJustify, Justification(JustifyLeft), labelSetText,- miscSetAlignment,- containerAdd,- deleteEvent,- statusIconNewFromFile, statusIconPopupMenu,- Menu, menuNew, menuItemNewWithMnemonic, menuItemActivated, menuPopup,- checkMenuItemNewWithMnemonic, checkMenuItemSetActive, checkMenuItemToggled- )-import qualified Graphics.UI.Gtk as G (get, set, on)+import Data.Text (Text, pack)+import Data.Word (Word32) import System.IO (stderr, hPutStrLn)+import System.Environment (getArgs) import WildBind ( ActionDescription, Option(optBindingHook), FrontEnd(frontDefaultDescription), Binding, Binding',@@ -70,6 +56,31 @@ import Paths_wild_bind_indicator (getDataFileName) +---- Imports about Gtk+import GI.Gdk.Functions (threadsAddIdle)+import GI.GLib.Constants (pattern PRIORITY_DEFAULT)+import GI.Gtk + ( -- Data.GI.Base.Attributes+ AttrOp((:=))+ )+import qualified GI.Gtk as GIAttr (set, get, on)+import GI.Gtk.Enums (WindowType(..), Justification(..))+import qualified GI.Gtk.Functions as GIFunc+import GI.Gtk.Objects.Button (buttonNew, buttonSetAlignment)+import GI.Gtk.Objects.CheckMenuItem (checkMenuItemNewWithMnemonic, checkMenuItemSetActive)+import GI.Gtk.Objects.Container (containerAdd)+import GI.Gtk.Objects.Label (Label, labelNew, labelSetLineWrap, labelSetJustify, labelSetText)+import GI.Gtk.Objects.Menu (Menu, menuNew, menuPopup)+import GI.Gtk.Objects.MenuItem (menuItemNewWithMnemonic)+import GI.Gtk.Objects.Misc (miscSetAlignment)+import GI.Gtk.Objects.StatusIcon (statusIconNewFromFile)+import GI.Gtk.Objects.Table (Table, tableNew, tableAttachDefaults)+import GI.Gtk.Objects.Widget (Widget, widgetSetSizeRequest, widgetShowAll, widgetHide)+import GI.Gtk.Objects.Window+ ( Window, windowNew, windowSetKeepAbove, windowSetTitle, windowMove+ )++ -- | Indicator interface. @s@ is the front-end state, @i@ is the input -- type. data Indicator s i =@@ -166,40 +177,38 @@ withNumPadIndicator :: (NumPadPosition i, Enum i, Bounded i) => (Indicator s i -> IO ()) -> IO () withNumPadIndicator action = if rtsSupportsBoundThreads then impl else error_impl where error_impl = throwIO $ userError "You need to build with -threaded option when you use WildBind.Indicator.withNumPadIndicator function."+ textArgs = fmap (map pack) $ getArgs impl = do- void $ initGUI+ void $ (GIFunc.init . Just) =<< textArgs conf <- numPadConfig indicator <- createMainWinAndIndicator conf status_icon <- createStatusIcon conf indicator status_icon_ref <- newIORef status_icon- mainGUI- void $ readIORef status_icon_ref -- to prevent status_icon from being garbage-collected. See https://github.com/gtk2hs/gtk2hs/issues/60+ withAsync (asyncAction indicator) $ \_ -> do+ GIFunc.main+ void $ readIORef status_icon_ref -- to prevent status_icon from being garbage-collected. See https://github.com/gtk2hs/gtk2hs/issues/60 createMainWinAndIndicator conf = flip runReaderT conf $ do win <- newNumPadWindow (tab, updater) <- newNumPadTable- liftIO $ containerAdd win tab+ containerAdd win tab let indicator = Indicator { updateDescription = \i d -> updater i d,- getPresence = G.get win widgetVisible,+ getPresence = GIAttr.get win #visible, setPresence = \visible -> if visible then widgetShowAll win else widgetHide win,- quit = mainQuit,+ quit = GIFunc.mainQuit, allButtons = enumFromTo minBound maxBound }- liftIO $ void $ G.on win deleteEvent $ do- liftIO $ widgetHide win+ void $ GIAttr.on win #deleteEvent $ \_ -> do+ widgetHide win return True -- Do not emit 'destroy' signal- liftIO $ void $ forkFinally (action $ transportIndicator indicator) finalAction return indicator- finalAction ret = do- case ret of- Right _ -> return ()- Left exception -> hPutStrLn stderr ("Fatal Error from WildBind: " ++ show exception)- postGUIAsync mainQuit+ asyncAction indicator =+ (action $ transportIndicator indicator) `finally` (postGUIAsync GIFunc.mainQuit) createStatusIcon conf indicator = do status_icon <- statusIconNewFromFile $ confIconPath conf- void $ G.on status_icon statusIconPopupMenu $ \mbutton time -> do+ void $ GIAttr.on status_icon #popupMenu $ \button time -> do menu <- makeStatusMenu indicator- menuPopup menu $ (\button -> return (button, time)) =<< mbutton+ menuPopup menu (Nothing :: Maybe Widget) (Nothing :: Maybe Widget) Nothing button time return status_icon @@ -218,17 +227,17 @@ newNumPadWindow :: NumPadContext Window newNumPadWindow = do- win <- liftIO $ windowNew- liftIO $ windowSetKeepAbove win True- liftIO $ G.set win [ windowSkipPagerHint := True,- windowSkipTaskbarHint := True,- windowAcceptFocus := False,- windowFocusOnMap := False- ]- liftIO $ windowSetTitle win ("WildBind Description" :: Text)- win_x <- confWindowX <$> ask- win_y <- confWindowY <$> ask- liftIO $ windowMove win win_x win_y+ win <- windowNew WindowTypeToplevel+ windowSetKeepAbove win True+ GIAttr.set win [ #skipPagerHint := True,+ #skipTaskbarHint := True,+ #acceptFocus := False,+ #focusOnMap := False+ ]+ windowSetTitle win "WildBind Description"+ win_x <- (fromIntegral . confWindowX) <$> ask+ win_y <- (fromIntegral . confWindowY) <$> ask+ windowMove win win_x win_y return win -- | Get the action to describe @i@, if that @i@ is supported. This is@@ -237,9 +246,9 @@ newNumPadTable :: NumPadPosition i => NumPadContext (Table, (i -> ActionDescription -> IO ())) newNumPadTable = do- tab <- liftIO $ tableNew 5 4 False+ tab <- tableNew 5 4 False -- NumLock is unboundable, so it's treatd in a different way from others.- (\label -> liftIO $ labelSetText label ("NumLock" :: Text)) =<< addButton tab 0 1 0 1+ (\label -> labelSetText label "NumLock") =<< addButton tab 0 1 0 1 descript_action_getter <- fmap mconcat $ sequence $ [ getter NumLDivide $ addButton tab 1 2 0 1,@@ -269,19 +278,19 @@ label <- get_label return $ \in_key -> First (if in_key == bound_key then Just $ labelSetText label else Nothing) -addButton :: Table -> Int -> Int -> Int -> Int -> NumPadContext Label+addButton :: Table -> Word32 -> Word32 -> Word32 -> Word32 -> NumPadContext Label addButton tab left right top bottom = do- lab <- liftIO $ labelNew (Nothing :: Maybe Text)- liftIO $ labelSetLineWrap lab True- liftIO $ miscSetAlignment lab 0 0.5- liftIO $ labelSetJustify lab JustifyLeft- button <- liftIO $ buttonNew- liftIO $ buttonSetAlignment button (0, 0.5)- liftIO $ containerAdd button lab- liftIO $ tableAttachDefaults tab button left right top bottom- bw <- confButtonWidth <$> ask- bh <- confButtonHeight <$> ask- liftIO $ widgetSetSizeRequest lab (bw * (right - left)) (bh * (bottom - top))+ lab <- labelNew Nothing+ labelSetLineWrap lab True+ miscSetAlignment lab 0 0.5+ labelSetJustify lab JustificationLeft+ button <- buttonNew+ buttonSetAlignment button 0 0.5+ containerAdd button lab+ tableAttachDefaults tab button left right top bottom+ bw <- (fromIntegral . confButtonWidth) <$> ask+ bh <- (fromIntegral . confButtonHeight) <$> ask+ widgetSetSizeRequest lab (bw * fromIntegral (right - left)) (bh * fromIntegral (bottom - top)) return lab makeStatusMenu :: Indicator s i -> IO Menu@@ -292,15 +301,15 @@ containerAdd menu =<< makeToggler return menu makeQuitItem = do- quit_item <- menuItemNewWithMnemonic ("_Quit" :: Text)+ quit_item <- menuItemNewWithMnemonic "_Quit" widgetShowAll quit_item- void $ G.on quit_item menuItemActivated (quit ind)+ void $ GIAttr.on quit_item #activate (quit ind) return quit_item makeToggler = do- toggler <- checkMenuItemNewWithMnemonic ("_Toggle description" :: Text)+ toggler <- checkMenuItemNewWithMnemonic "_Toggle description" widgetShowAll toggler checkMenuItemSetActive toggler =<< getPresence ind- void $ G.on toggler checkMenuItemToggled (togglePresence ind)+ void $ GIAttr.on toggler #toggled (togglePresence ind) return toggler -- | Map input type of 'Indicator', so that it can adapt to the new@@ -333,3 +342,23 @@ toggleBinding ind button = binding $ map (\input -> (input, Action "Toggle description" $ togglePresence ind)) help_likes where help_likes = filter ((== button) . toNumPad) $ enumFromTo minBound maxBound+++-- | Schedule the given action to be executed by Gdk. The given action+-- can include manipulation of Gtk+ objects. This function can be+-- called by a thread that is different from the Gtk+ main loop+-- thread. This function doesn't wait for the given action to finish.+--+-- See https://github.com/haskell-gi/haskell-gi/wiki/Using-threads-in-Gdk-and-Gtk--programs+postGUIAsync :: IO () -> IO ()+postGUIAsync action = void $ threadsAddIdle PRIORITY_DEFAULT (action >> return False)++-- | Similar to 'postGUIAsync', but this function waits for the action+-- to finish.+postGUISync :: IO a -> IO a+postGUISync action = do+ mret <- newEmptyMVar+ postGUIAsync $ do+ ret <- action+ putMVar mret ret+ takeMVar mret
wild-bind-indicator.cabal view
@@ -1,5 +1,5 @@ name: wild-bind-indicator-version: 0.2.0.0+version: 1.0.0.0 author: Toshio Ito <debug.ito@gmail.com> maintainer: Toshio Ito <debug.ito@gmail.com> license: BSD3@@ -19,15 +19,18 @@ default-language: Haskell2010 hs-source-dirs: src ghc-options: -Wall -fno-warn-unused-imports- other-extensions: OverloadedStrings+ other-extensions: OverloadedStrings, OverloadedLabels exposed-modules: WildBind.Indicator other-modules: Paths_wild_bind_indicator- build-depends: base >=4.6 && <5.0,+ build-depends: base >=4.9 && <5.0, wild-bind >=0.1.0 && <0.2, transformers >=0.3.0 && <0.6,- gtk >=0.14.2 && <0.15,+ gi-gtk >=3.0.3 && <3.1,+ gi-gdk >=3.0.3 && <3.1,+ gi-glib >=2.0.3 && <2.1,+ async >=2.1.1.1 && <2.3, text >=1.2.0 && <1.3,- containers >=0.5.0 && <0.6+ containers >=0.5.0 && <0.7 -- executable wild-bind-indicator -- default-language: Haskell2010