wild-bind-indicator (empty) → 0.1.0.1
raw patch · 7 files changed
+476/−0 lines, 7 filesdep +basedep +containersdep +gtksetup-changed
Dependencies added: base, containers, gtk, text, transformers, wild-bind
Files
- ChangeLog.md +5/−0
- LICENSE +30/−0
- README.md +9/−0
- Setup.hs +2/−0
- resources/icon.svg +84/−0
- src/WildBind/Indicator.hs +293/−0
- wild-bind-indicator.cabal +53/−0
+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Revision history for wild-bind-indicator++## 0.1.0.1 -- 2016-09-22++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -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.
+ README.md view
@@ -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 <debug.ito@gmail.com>
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ resources/icon.svg view
@@ -0,0 +1,84 @@+<?xml version="1.0" encoding="UTF-8" standalone="no"?>+<!-- Created with Inkscape (http://www.inkscape.org/) -->++<svg+ xmlns:osb="http://www.openswatchbook.org/uri/2009/osb"+ xmlns:dc="http://purl.org/dc/elements/1.1/"+ xmlns:cc="http://creativecommons.org/ns#"+ xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"+ xmlns:svg="http://www.w3.org/2000/svg"+ xmlns="http://www.w3.org/2000/svg"+ xmlns:sodipodi="http://sodipodi.sourceforge.net/DTD/sodipodi-0.dtd"+ xmlns:inkscape="http://www.inkscape.org/namespaces/inkscape"+ width="247.59608mm"+ height="247.59608mm"+ viewBox="0 0 877.30896 877.30896"+ id="svg2"+ version="1.1"+ inkscape:version="0.91 r13725"+ sodipodi:docname="wild-bind-logo.svg">+ <defs+ id="defs4">+ <linearGradient+ id="linearGradient4279"+ osb:paint="solid">+ <stop+ style="stop-color:#bf0000;stop-opacity:1;"+ offset="0"+ id="stop4281" />+ </linearGradient>+ </defs>+ <sodipodi:namedview+ id="base"+ pagecolor="#ffffff"+ bordercolor="#666666"+ borderopacity="1.0"+ inkscape:pageopacity="0.0"+ inkscape:pageshadow="2"+ inkscape:zoom="0.24748737"+ inkscape:cx="410.42879"+ inkscape:cy="338.02021"+ inkscape:document-units="px"+ inkscape:current-layer="g4160"+ showgrid="false"+ inkscape:window-width="1360"+ inkscape:window-height="721"+ inkscape:window-x="0"+ inkscape:window-y="0"+ inkscape:window-maximized="1"+ inkscape:snap-global="false"+ fit-margin-top="2"+ fit-margin-left="2"+ fit-margin-right="2"+ fit-margin-bottom="2" />+ <metadata+ id="metadata7">+ <rdf:RDF>+ <cc:Work+ rdf:about="">+ <dc:format>image/svg+xml</dc:format>+ <dc:type+ rdf:resource="http://purl.org/dc/dcmitype/StillImage" />+ <dc:title></dc:title>+ </cc:Work>+ </rdf:RDF>+ </metadata>+ <g+ inkscape:groupmode="layer"+ id="g4160"+ inkscape:label="main3"+ transform="translate(105.71384,-168.26397)">+ <circle+ style="fill:#003700;fill-opacity:1;fill-rule:nonzero;stroke:none;stroke-width:10;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"+ id="path4166"+ cx="332.94064"+ cy="606.91846"+ r="431.56787" />+ <path+ style="fill:#ffffff;fill-opacity:1;fill-rule:nonzero;stroke:none;stroke-width:0.96742737px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1"+ d="M -99.663136,599.91585 C 25.887206,581.71989 153.27129,504.38565 180.6188,365.0203 c -160.569443,87.41872 -59.60649,503.13018 14.68719,501.75029 74.29368,-1.3799 153.92758,-142.58954 133.7753,-259.66225 -97.14428,90.30416 -45.07859,260.3131 1.69832,260.67243 46.7769,0.35934 81.23426,-178.78379 91.9528,-233.45685 10.71854,-54.67305 46.29188,-134.28518 91.10763,-165.0959 -32.48082,-42.46761 -17.30983,-89.42614 -5.02206,-106.80841 12.28778,-17.38226 28.00984,-31.3158 32.74997,-67.17744 4.74012,28.79033 20.19357,43.75693 31.88813,67.68254 11.69456,23.9256 15.51313,54.045 6.89472,86.37098 44.28473,-66.89482 87.94063,-59.11513 144.78935,-21.71901 -38.54293,77.80808 -77.68706,91.44701 -118.50318,86.37099 33.96871,14.64543 44.73285,80.58533 45.31892,92.83351 0.58607,12.24819 5.10375,22.42777 12.6399,27.88385 C 576.04683,655.10287 559.73987,600.01915 554.37833,542.8903 509.29714,618.29905 506.33282,675.0693 491.52441,747.28646 476.71601,819.50361 434.40924,915.7411 358.08073,920.98637 281.75221,926.23164 156.27568,843.42459 181.81533,702.21313 207.35499,561.00167 398.62999,456.79854 382.36016,675.92723 366.09032,895.05592 228.97549,919.20159 187.0192,918.72088 145.0629,918.24018 -1.8988514,867.74179 -6.7026463,632.70095 -11.506442,397.66012 139.78398,309.75635 202.05285,324.50767 264.32171,339.25898 214.90052,490.97416 140.42594,568.61611 78.044679,633.65041 -14.857613,677.39916 -87.787544,706.7625 -96.173486,671.83742 -100.56868,645.47297 -99.663136,599.91585 Z"+ id="path4162"+ inkscape:connector-curvature="0"+ sodipodi:nodetypes="cczczzczczccczcczzzzzzzscc" />+ </g>+</svg>
+ src/WildBind/Indicator.hs view
@@ -0,0 +1,293 @@+-- |+-- Module: WildBind.Indicator+-- Description: Graphical indicator for WildBind+-- Maintainer: Toshio Ito <debug.ito@gmail.com>+-- +-- 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
+ wild-bind-indicator.cabal view
@@ -0,0 +1,53 @@+name: wild-bind-indicator+version: 0.1.0.1+author: Toshio Ito <debug.ito@gmail.com>+maintainer: Toshio Ito <debug.ito@gmail.com>+license: BSD3+license-file: LICENSE+synopsis: Graphical indicator for WildBind+description: Graphical indicator for WildBind. See <https://github.com/debug-ito/wild-bind>+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