diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Revision history for wild-bind-indicator + +## 0.1.0.1 -- 2016-09-22 + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2015, Toshio Ito + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Toshio Ito nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,9 @@ +# wild-bind-indicator + +Graphical indicator for WildBind + +See https://github.com/debug-ito/wild-bind for WildBind in general. + +## Author + +Toshio Ito diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/resources/icon.svg b/resources/icon.svg new file mode 100644 --- /dev/null +++ b/resources/icon.svg @@ -0,0 +1,84 @@ + + + + + + + + + + + + + + image/svg+xml + + + + + + + + + + diff --git a/src/WildBind/Indicator.hs b/src/WildBind/Indicator.hs new file mode 100644 --- /dev/null +++ b/src/WildBind/Indicator.hs @@ -0,0 +1,293 @@ +-- | +-- Module: WildBind.Indicator +-- Description: Graphical indicator for WildBind +-- Maintainer: Toshio Ito +-- +-- This module exports the 'Indicator', a graphical interface that +-- explains the current bindings to the user. The 'Indicator' uses +-- 'optBindingHook' in 'Option' to receive the current bindings from +-- wild-bind. +module WildBind.Indicator + ( -- * Construction + withNumPadIndicator, + -- * Execution + wildBindWithIndicator, + -- * Low-level function + bindingHook, + -- * Indicator type and its actions + Indicator, + updateDescription, + getPresence, + setPresence, + togglePresence, + quit, + -- * Generalization of number pad types + NumPadPosition(..) + ) where + +import Control.Applicative ((<$>)) +import Control.Concurrent (forkFinally, rtsSupportsBoundThreads) +import Control.Exception (throwIO) +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 System.IO (stderr, hPutStrLn) + +import WildBind ( ActionDescription, Option(optBindingHook), + FrontEnd(frontDefaultDescription), Binding, + wildBind', defOption + ) +import WildBind.Input.NumPad (NumPadUnlocked(..), NumPadLocked(..)) + +import Paths_wild_bind_indicator (getDataFileName) + + +-- | Indicator interface. @s@ is the front-end state, @i@ is the input +-- type. +data Indicator s i = + Indicator + { updateDescription :: i -> ActionDescription -> IO (), + -- ^ Update and show the description for the current binding. + + getPresence :: IO Bool, + + -- ^ Get the current presence of the indicator. Returns 'True' if + -- it's present. + + setPresence :: Bool -> IO (), + -- ^ Set the presence of the indicator. + + quit :: IO () + -- ^ Destroy the indicator. This usually means quitting the entire + -- application. + } + +-- | Toggle the presence of the indicator. +togglePresence :: Indicator s i -> IO () +togglePresence ind = (setPresence ind . not) =<< getPresence ind + +-- | Convert actions in the input 'Indicator' so that those actions +-- can be executed from a non-GTK-main thread. +transportIndicator :: Indicator s i -> Indicator s i +transportIndicator ind = Indicator { updateDescription = \i d -> postGUIAsync $ updateDescription ind i d, + getPresence = postGUISync $ getPresence ind, + setPresence = \visible -> postGUIAsync $ setPresence ind visible, + quit = postGUISync $ quit ind + } + + +-- | Something that can be mapped to number pad's key positions. +class NumPadPosition a where + toNumPad :: a -> NumPadLocked + +instance NumPadPosition NumPadLocked where + toNumPad = id + +instance NumPadPosition NumPadUnlocked where + toNumPad input = case input of + NumInsert -> NumL0 + NumEnd -> NumL1 + NumDown -> NumL2 + NumPageDown -> NumL3 + NumLeft -> NumL4 + NumCenter -> NumL5 + NumRight -> NumL6 + NumHome -> NumL7 + NumUp -> NumL8 + NumPageUp -> NumL9 + NumDivide -> NumLDivide + NumMulti -> NumLMulti + NumMinus -> NumLMinus + NumPlus -> NumLPlus + NumEnter -> NumLEnter + NumDelete -> NumLPeriod + +-- | Data type keeping read-only config for NumPadIndicator. +data NumPadConfig = + NumPadConfig { confButtonWidth, confButtonHeight :: Int, + confWindowX, confWindowY :: Int, + confIconPath :: FilePath + } + +numPadConfig :: IO NumPadConfig +numPadConfig = do + icon <- getDataFileName "icon.svg" + return NumPadConfig + { confButtonWidth = 70, + confButtonHeight = 45, + confWindowX = 0, + confWindowY = 0, + confIconPath = icon + } + +-- | Contextual monad for creating NumPadIndicator +type NumPadContext = ReaderT NumPadConfig IO + +-- | Initialize the indicator and run the given action. This function +-- should be used directly under @main@ function. +-- +-- > main :: IO () +-- > main = withNumPadIndicator $ \indicator -> ... +-- +-- The executable must be compiled by ghc with __@-threaded@ option enabled.__ +-- Otherwise, it aborts. +withNumPadIndicator :: NumPadPosition 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." + impl = do + void $ initGUI + 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 + createMainWinAndIndicator conf = flip runReaderT conf $ do + win <- newNumPadWindow + (tab, updater) <- newNumPadTable + liftIO $ containerAdd win tab + let indicator = Indicator + { updateDescription = \i d -> updater i d, + getPresence = G.get win widgetVisible, + setPresence = \visible -> if visible then widgetShowAll win else widgetHide win, + quit = mainQuit + } + liftIO $ void $ G.on win deleteEvent $ do + liftIO $ 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 + createStatusIcon conf indicator = do + status_icon <- statusIconNewFromFile $ confIconPath conf + void $ G.on status_icon statusIconPopupMenu $ \mbutton time -> do + menu <- makeStatusMenu indicator + menuPopup menu $ (\button -> return (button, time)) =<< mbutton + return status_icon + + +-- | Run 'WildBind.wildBind' with the given 'Indicator'. 'ActionDescription's +-- are shown by the 'Indicator'. +wildBindWithIndicator :: (Ord i, Enum i, Bounded i) => Indicator s i -> Binding s i -> FrontEnd s i -> IO () +wildBindWithIndicator ind binding front = wildBind' (defOption { optBindingHook = bindingHook ind front }) binding front + +-- | Create an action appropriate for 'optBindingHook' in 'Option' +-- from 'Indicator' and 'FrontEnd'. +bindingHook :: (Ord i, Enum i, Bounded i) => Indicator s1 i -> FrontEnd s2 i -> [(i, ActionDescription)] -> IO () +bindingHook ind front bind_list = forM_ (enumFromTo minBound maxBound) $ \input -> do + let desc = M.findWithDefault (frontDefaultDescription front input) input (M.fromList bind_list) + updateDescription ind input desc + + +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 + return win + +-- | Get the action to describe @i@, if that @i@ is supported. This is +-- a 'Monoid', so we can build up the getter by 'mconcat'. +type DescriptActionGetter i = i -> First (ActionDescription -> IO ()) + +newNumPadTable :: NumPadPosition i => NumPadContext (Table, (i -> ActionDescription -> IO ())) +newNumPadTable = do + tab <- liftIO $ 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 + descript_action_getter <- + fmap mconcat $ sequence $ + [ getter NumLDivide $ addButton tab 1 2 0 1, + getter NumLMulti $ addButton tab 2 3 0 1, + getter NumLMinus $ addButton tab 3 4 0 1, + getter NumL7 $ addButton tab 0 1 1 2, + getter NumL8 $ addButton tab 1 2 1 2, + getter NumL9 $ addButton tab 2 3 1 2, + getter NumLPlus $ addButton tab 3 4 1 3, + getter NumL4 $ addButton tab 0 1 2 3, + getter NumL5 $ addButton tab 1 2 2 3, + getter NumL6 $ addButton tab 2 3 2 3, + getter NumL1 $ addButton tab 0 1 3 4, + getter NumL2 $ addButton tab 1 2 3 4, + getter NumL3 $ addButton tab 2 3 3 4, + getter NumLEnter $ addButton tab 3 4 3 5, + getter NumL0 $ addButton tab 0 2 4 5, + getter NumLPeriod $ addButton tab 2 3 4 5 + ] + let description_updater = \input -> case descript_action_getter $ toNumPad input of + First (Just act) -> act + First Nothing -> const $ return () + return (tab, description_updater) + where + getter :: Eq i => i -> NumPadContext Label -> NumPadContext (DescriptActionGetter i) + getter bound_key get_label = do + 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 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)) + return lab + +makeStatusMenu :: Indicator s i -> IO Menu +makeStatusMenu ind = impl where + impl = do + menu <- menuNew + containerAdd menu =<< makeQuitItem + containerAdd menu =<< makeToggler + return menu + makeQuitItem = do + quit_item <- menuItemNewWithMnemonic ("_Quit" :: Text) + widgetShowAll quit_item + void $ G.on quit_item menuItemActivated (quit ind) + return quit_item + makeToggler = do + toggler <- checkMenuItemNewWithMnemonic ("_Toggle description" :: Text) + widgetShowAll toggler + checkMenuItemSetActive toggler =<< getPresence ind + void $ G.on toggler checkMenuItemToggled (togglePresence ind) + return toggler diff --git a/wild-bind-indicator.cabal b/wild-bind-indicator.cabal new file mode 100644 --- /dev/null +++ b/wild-bind-indicator.cabal @@ -0,0 +1,53 @@ +name: wild-bind-indicator +version: 0.1.0.1 +author: Toshio Ito +maintainer: Toshio Ito +license: BSD3 +license-file: LICENSE +synopsis: Graphical indicator for WildBind +description: Graphical indicator for WildBind. See +category: UserInterface +cabal-version: >= 1.10 +build-type: Simple +extra-source-files: README.md, ChangeLog.md +homepage: https://github.com/debug-ito/wild-bind +bug-reports: https://github.com/debug-ito/wild-bind/issues +data-dir: resources +data-files: icon.svg + +library + default-language: Haskell2010 + hs-source-dirs: src + ghc-options: -Wall -fno-warn-unused-imports + default-extensions: OverloadedStrings + exposed-modules: WildBind.Indicator + other-modules: Paths_wild_bind_indicator + build-depends: base >=4.6 && <5.0, + wild-bind >=0.1.0 && <0.2, + transformers >=0.3.0 && <0.6, + gtk >=0.14.2 && <0.15, + text >=1.2.0 && <1.3, + containers >=0.5.0 && <0.6 + +-- executable wild-bind-indicator +-- default-language: Haskell2010 +-- hs-source-dirs: src +-- main-is: Main.hs +-- ghc-options: -Wall -fno-warn-unused-imports +-- -- other-modules: +-- -- other-extensions: +-- build-depends: base >=4 && <5 + +-- test-suite spec +-- type: exitcode-stdio-1.0 +-- default-language: Haskell2010 +-- hs-source-dirs: test +-- ghc-options: -Wall -fno-warn-unused-imports +-- main-is: Spec.hs +-- other-modules: WildBind.IndicatorSpec +-- build-depends: base, wild-bind-indicator, +-- hspec + +source-repository head + type: git + location: https://github.com/debug-ito/wild-bind.git