{-# LANGUAGE OverloadedStrings, OverloadedLabels, PatternSynonyms #-}
-- |
-- 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,
         -- ** Conversion
         adaptIndicator,
         -- ** Binding
         toggleBinding,
         -- * Generalization of number pad types
         NumPadPosition(..)
       ) where

import Control.Applicative ((<$>))
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, pack)
import Data.Word (Word32)
import System.IO (stderr, hPutStrLn)
import System.Environment (getArgs)

import WildBind ( ActionDescription, Option(optBindingHook),
                  FrontEnd(frontDefaultDescription), Binding, Binding',
                  binding, Action(Action),
                  wildBind', defOption
                )
import WildBind.Input.NumPad (NumPadUnlocked(..), NumPadLocked(..))

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 =
  Indicator
  { forall s i. Indicator s i -> i -> Text -> IO ()
updateDescription :: i -> ActionDescription -> IO (),
    -- ^ Update and show the description for the current binding.
    
    forall s i. Indicator s i -> IO Bool
getPresence :: IO Bool,
    
    -- ^ Get the current presence of the indicator. Returns 'True' if
    -- it's present.
    
    forall s i. Indicator s i -> Bool -> IO ()
setPresence :: Bool -> IO (),
    -- ^ Set the presence of the indicator.

    forall s i. Indicator s i -> IO ()
quit :: IO (),
    -- ^ Destroy the indicator. This usually means quitting the entire
    -- application.

    forall s i. Indicator s i -> [i]
allButtons :: [i]
    -- ^ list of all buttons on which the indicator displays
    -- descriptions.
  }

-- | Toggle the presence of the indicator.
togglePresence :: Indicator s i -> IO ()
togglePresence :: forall s i. Indicator s i -> IO ()
togglePresence Indicator s i
ind = (Indicator s i -> Bool -> IO ()
forall s i. Indicator s i -> Bool -> IO ()
setPresence Indicator s i
ind (Bool -> IO ()) -> (Bool -> Bool) -> Bool -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Bool
not) (Bool -> IO ()) -> IO Bool -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Indicator s i -> IO Bool
forall s i. Indicator s i -> IO Bool
getPresence Indicator s i
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 :: forall s i. Indicator s i -> Indicator s i
transportIndicator Indicator s i
ind = Indicator s i
ind { updateDescription :: i -> Text -> IO ()
updateDescription = \i
i Text
d -> IO () -> IO ()
postGUIAsync (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Indicator s i -> i -> Text -> IO ()
forall s i. Indicator s i -> i -> Text -> IO ()
updateDescription Indicator s i
ind i
i Text
d,
                               getPresence :: IO Bool
getPresence = IO Bool -> IO Bool
forall a. IO a -> IO a
postGUISync (IO Bool -> IO Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Indicator s i -> IO Bool
forall s i. Indicator s i -> IO Bool
getPresence Indicator s i
ind,
                               setPresence :: Bool -> IO ()
setPresence = \Bool
visible -> IO () -> IO ()
postGUIAsync (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Indicator s i -> Bool -> IO ()
forall s i. Indicator s i -> Bool -> IO ()
setPresence Indicator s i
ind Bool
visible,
                               quit :: IO ()
quit = IO () -> IO ()
forall a. IO a -> IO a
postGUISync (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Indicator s i -> IO ()
forall s i. Indicator s i -> IO ()
quit Indicator s i
ind
                             }


-- | Something that can be mapped to number pad's key positions.
class NumPadPosition a where
  toNumPad :: a -> NumPadLocked

instance NumPadPosition NumPadLocked where
  toNumPad :: NumPadLocked -> NumPadLocked
toNumPad = NumPadLocked -> NumPadLocked
forall a. a -> a
id

instance NumPadPosition NumPadUnlocked where
  toNumPad :: NumPadUnlocked -> NumPadLocked
toNumPad NumPadUnlocked
input = case NumPadUnlocked
input of
    NumPadUnlocked
NumInsert -> NumPadLocked
NumL0
    NumPadUnlocked
NumEnd -> NumPadLocked
NumL1
    NumPadUnlocked
NumDown -> NumPadLocked
NumL2
    NumPadUnlocked
NumPageDown -> NumPadLocked
NumL3
    NumPadUnlocked
NumLeft -> NumPadLocked
NumL4
    NumPadUnlocked
NumCenter -> NumPadLocked
NumL5
    NumPadUnlocked
NumRight -> NumPadLocked
NumL6
    NumPadUnlocked
NumHome -> NumPadLocked
NumL7
    NumPadUnlocked
NumUp -> NumPadLocked
NumL8
    NumPadUnlocked
NumPageUp -> NumPadLocked
NumL9
    NumPadUnlocked
NumDivide -> NumPadLocked
NumLDivide
    NumPadUnlocked
NumMulti -> NumPadLocked
NumLMulti
    NumPadUnlocked
NumMinus -> NumPadLocked
NumLMinus
    NumPadUnlocked
NumPlus -> NumPadLocked
NumLPlus
    NumPadUnlocked
NumEnter -> NumPadLocked
NumLEnter
    NumPadUnlocked
NumDelete -> NumPadLocked
NumLPeriod

-- | Data type keeping read-only config for NumPadIndicator.
data NumPadConfig =
  NumPadConfig { NumPadConfig -> Int
confButtonWidth, NumPadConfig -> Int
confButtonHeight :: Int,
                 NumPadConfig -> Int
confWindowX, NumPadConfig -> Int
confWindowY :: Int,
                 NumPadConfig -> FilePath
confIconPath :: FilePath
               }

numPadConfig :: IO NumPadConfig
numPadConfig :: IO NumPadConfig
numPadConfig = do
  FilePath
icon <- FilePath -> IO FilePath
getDataFileName FilePath
"icon.svg"
  NumPadConfig -> IO NumPadConfig
forall (m :: * -> *) a. Monad m => a -> m a
return NumPadConfig :: Int -> Int -> Int -> Int -> FilePath -> NumPadConfig
NumPadConfig
    { confButtonWidth :: Int
confButtonWidth = Int
70,
      confButtonHeight :: Int
confButtonHeight = Int
45,
      confWindowX :: Int
confWindowX = Int
0,
      confWindowY :: Int
confWindowY = Int
0,
      confIconPath :: FilePath
confIconPath = FilePath
icon
    }

-- | Contextual monad for creating NumPadIndicator
type NumPadContext = ReaderT NumPadConfig IO

-- | Initialize the indicator and run the given action.
-- 
-- The executable must be compiled by ghc with __@-threaded@ option enabled.__
-- Otherwise, it aborts.
withNumPadIndicator :: (NumPadPosition i, Enum i, Bounded i) => (Indicator s i -> IO ()) -> IO ()
withNumPadIndicator :: forall i s.
(NumPadPosition i, Enum i, Bounded i) =>
(Indicator s i -> IO ()) -> IO ()
withNumPadIndicator Indicator s i -> IO ()
action = if Bool
rtsSupportsBoundThreads then IO ()
impl else IO ()
forall {a}. IO a
error_impl where
  error_impl :: IO a
error_impl = IOError -> IO a
forall e a. Exception e => e -> IO a
throwIO (IOError -> IO a) -> IOError -> IO a
forall a b. (a -> b) -> a -> b
$ FilePath -> IOError
userError FilePath
"You need to build with -threaded option when you use WildBind.Indicator.withNumPadIndicator function."
  textArgs :: IO [Text]
textArgs = ([FilePath] -> [Text]) -> IO [FilePath] -> IO [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((FilePath -> Text) -> [FilePath] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Text
pack) (IO [FilePath] -> IO [Text]) -> IO [FilePath] -> IO [Text]
forall a b. (a -> b) -> a -> b
$ IO [FilePath]
getArgs
  impl :: IO ()
impl = do
    IO (Maybe [Text]) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe [Text]) -> IO ()) -> IO (Maybe [Text]) -> IO ()
forall a b. (a -> b) -> a -> b
$ (Maybe [Text] -> IO (Maybe [Text])
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Maybe [Text] -> m (Maybe [Text])
GIFunc.init (Maybe [Text] -> IO (Maybe [Text]))
-> ([Text] -> Maybe [Text]) -> [Text] -> IO (Maybe [Text])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Maybe [Text]
forall a. a -> Maybe a
Just) ([Text] -> IO (Maybe [Text])) -> IO [Text] -> IO (Maybe [Text])
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO [Text]
textArgs
    NumPadConfig
conf <- IO NumPadConfig
numPadConfig
    Indicator s i
indicator <- NumPadConfig -> IO (Indicator s i)
forall {i} {s}.
(NumPadPosition i, Enum i, Bounded i) =>
NumPadConfig -> IO (Indicator s i)
createMainWinAndIndicator NumPadConfig
conf
    StatusIcon
status_icon <- NumPadConfig -> Indicator s i -> IO StatusIcon
forall {m :: * -> *} {s} {i}.
MonadIO m =>
NumPadConfig -> Indicator s i -> m StatusIcon
createStatusIcon NumPadConfig
conf Indicator s i
indicator
    IORef StatusIcon
status_icon_ref <- StatusIcon -> IO (IORef StatusIcon)
forall a. a -> IO (IORef a)
newIORef StatusIcon
status_icon
    IO () -> (Async () -> IO ()) -> IO ()
forall a b. IO a -> (Async a -> IO b) -> IO b
withAsync (Indicator s i -> IO ()
asyncAction Indicator s i
indicator) ((Async () -> IO ()) -> IO ()) -> (Async () -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Async ()
_ -> do
      IO ()
forall (m :: * -> *). (HasCallStack, MonadIO m) => m ()
GIFunc.main
      IO StatusIcon -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO StatusIcon -> IO ()) -> IO StatusIcon -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef StatusIcon -> IO StatusIcon
forall a. IORef a -> IO a
readIORef IORef StatusIcon
status_icon_ref -- to prevent status_icon from being garbage-collected. See https://github.com/gtk2hs/gtk2hs/issues/60
  createMainWinAndIndicator :: NumPadConfig -> IO (Indicator s i)
createMainWinAndIndicator NumPadConfig
conf = (ReaderT NumPadConfig IO (Indicator s i)
 -> NumPadConfig -> IO (Indicator s i))
-> NumPadConfig
-> ReaderT NumPadConfig IO (Indicator s i)
-> IO (Indicator s i)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT NumPadConfig IO (Indicator s i)
-> NumPadConfig -> IO (Indicator s i)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT NumPadConfig
conf (ReaderT NumPadConfig IO (Indicator s i) -> IO (Indicator s i))
-> ReaderT NumPadConfig IO (Indicator s i) -> IO (Indicator s i)
forall a b. (a -> b) -> a -> b
$ do
    Window
win <- NumPadContext Window
newNumPadWindow
    (Table
tab, i -> Text -> IO ()
updater) <- NumPadContext (Table, i -> Text -> IO ())
forall i.
NumPadPosition i =>
NumPadContext (Table, i -> Text -> IO ())
newNumPadTable
    Window -> Table -> ReaderT NumPadConfig IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsContainer a, IsWidget b) =>
a -> b -> m ()
containerAdd Window
win Table
tab
    let indicator :: Indicator s i
indicator = Indicator :: forall s i.
(i -> Text -> IO ())
-> IO Bool -> (Bool -> IO ()) -> IO () -> [i] -> Indicator s i
Indicator
          { updateDescription :: i -> Text -> IO ()
updateDescription = \i
i Text
d -> i -> Text -> IO ()
updater i
i Text
d,
            getPresence :: IO Bool
getPresence = Window -> AttrLabelProxy "visible" -> IO Bool
forall info (attr :: Symbol) obj result (m :: * -> *).
(AttrGetC info obj attr result, MonadIO m) =>
obj -> AttrLabelProxy attr -> m result
GIAttr.get Window
win IsLabel "visible" (AttrLabelProxy "visible")
AttrLabelProxy "visible"
#visible,
            setPresence :: Bool -> IO ()
setPresence = \Bool
visible -> if Bool
visible then Window -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
widgetShowAll Window
win else Window -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
widgetHide Window
win,
            quit :: IO ()
quit = IO ()
forall (m :: * -> *). (HasCallStack, MonadIO m) => m ()
GIFunc.mainQuit,
            allButtons :: [i]
allButtons = i -> i -> [i]
forall a. Enum a => a -> a -> [a]
enumFromTo i
forall a. Bounded a => a
minBound i
forall a. Bounded a => a
maxBound
          }
    ReaderT NumPadConfig IO SignalHandlerId
-> ReaderT NumPadConfig IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReaderT NumPadConfig IO SignalHandlerId
 -> ReaderT NumPadConfig IO ())
-> ReaderT NumPadConfig IO SignalHandlerId
-> ReaderT NumPadConfig IO ()
forall a b. (a -> b) -> a -> b
$ Window
-> SignalProxy Window WidgetDeleteEventSignalInfo
-> HaskellCallbackType WidgetDeleteEventSignalInfo
-> ReaderT NumPadConfig IO SignalHandlerId
forall object info (m :: * -> *).
(GObject object, MonadIO m, SignalInfo info) =>
object
-> SignalProxy object info
-> HaskellCallbackType info
-> m SignalHandlerId
GIAttr.on Window
win IsLabel
  "deleteEvent" (SignalProxy Window WidgetDeleteEventSignalInfo)
SignalProxy Window WidgetDeleteEventSignalInfo
#deleteEvent (HaskellCallbackType WidgetDeleteEventSignalInfo
 -> ReaderT NumPadConfig IO SignalHandlerId)
-> HaskellCallbackType WidgetDeleteEventSignalInfo
-> ReaderT NumPadConfig IO SignalHandlerId
forall a b. (a -> b) -> a -> b
$ \Event
_ -> do
      Window -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
widgetHide Window
win
      Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True -- Do not emit 'destroy' signal
    Indicator s i -> ReaderT NumPadConfig IO (Indicator s i)
forall (m :: * -> *) a. Monad m => a -> m a
return Indicator s i
forall {s}. Indicator s i
indicator
  asyncAction :: Indicator s i -> IO ()
asyncAction Indicator s i
indicator =
    (Indicator s i -> IO ()
action (Indicator s i -> IO ()) -> Indicator s i -> IO ()
forall a b. (a -> b) -> a -> b
$ Indicator s i -> Indicator s i
forall s i. Indicator s i -> Indicator s i
transportIndicator Indicator s i
indicator) IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`finally` (IO () -> IO ()
postGUIAsync IO ()
forall (m :: * -> *). (HasCallStack, MonadIO m) => m ()
GIFunc.mainQuit) 
  createStatusIcon :: NumPadConfig -> Indicator s i -> m StatusIcon
createStatusIcon NumPadConfig
conf Indicator s i
indicator = do
    StatusIcon
status_icon <- FilePath -> m StatusIcon
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
FilePath -> m StatusIcon
statusIconNewFromFile (FilePath -> m StatusIcon) -> FilePath -> m StatusIcon
forall a b. (a -> b) -> a -> b
$ NumPadConfig -> FilePath
confIconPath NumPadConfig
conf
    m SignalHandlerId -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m SignalHandlerId -> m ()) -> m SignalHandlerId -> m ()
forall a b. (a -> b) -> a -> b
$ StatusIcon
-> SignalProxy StatusIcon StatusIconPopupMenuSignalInfo
-> HaskellCallbackType StatusIconPopupMenuSignalInfo
-> m SignalHandlerId
forall object info (m :: * -> *).
(GObject object, MonadIO m, SignalInfo info) =>
object
-> SignalProxy object info
-> HaskellCallbackType info
-> m SignalHandlerId
GIAttr.on StatusIcon
status_icon IsLabel
  "popupMenu" (SignalProxy StatusIcon StatusIconPopupMenuSignalInfo)
SignalProxy StatusIcon StatusIconPopupMenuSignalInfo
#popupMenu (HaskellCallbackType StatusIconPopupMenuSignalInfo
 -> m SignalHandlerId)
-> HaskellCallbackType StatusIconPopupMenuSignalInfo
-> m SignalHandlerId
forall a b. (a -> b) -> a -> b
$ \Word32
button Word32
time -> do
      Menu
menu <- Indicator s i -> IO Menu
forall s i. Indicator s i -> IO Menu
makeStatusMenu Indicator s i
indicator
      Menu
-> Maybe Widget
-> Maybe Widget
-> Maybe MenuPositionFunc
-> Word32
-> Word32
-> IO ()
forall (m :: * -> *) a b c.
(HasCallStack, MonadIO m, IsMenu a, IsWidget b, IsWidget c) =>
a
-> Maybe b
-> Maybe c
-> Maybe MenuPositionFunc
-> Word32
-> Word32
-> m ()
menuPopup Menu
menu (Maybe Widget
forall a. Maybe a
Nothing :: Maybe Widget) (Maybe Widget
forall a. Maybe a
Nothing :: Maybe Widget) Maybe MenuPositionFunc
forall a. Maybe a
Nothing Word32
button Word32
time
    StatusIcon -> m StatusIcon
forall (m :: * -> *) a. Monad m => a -> m a
return StatusIcon
status_icon


-- | Run 'WildBind.wildBind' with the given 'Indicator'. 'ActionDescription's
-- are shown by the 'Indicator'.
wildBindWithIndicator :: Ord i => Indicator s i -> Binding s i -> FrontEnd s i -> IO ()
wildBindWithIndicator :: forall i s.
Ord i =>
Indicator s i -> Binding s i -> FrontEnd s i -> IO ()
wildBindWithIndicator Indicator s i
ind Binding s i
b FrontEnd s i
front = Option s i -> Binding s i -> FrontEnd s i -> IO ()
forall i s.
Ord i =>
Option s i -> Binding s i -> FrontEnd s i -> IO ()
wildBind' (Option s i
forall s i. Option s i
defOption { optBindingHook :: [(i, Text)] -> IO ()
optBindingHook = Indicator s i -> FrontEnd s i -> [(i, Text)] -> IO ()
forall i s1 s2.
Ord i =>
Indicator s1 i -> FrontEnd s2 i -> [(i, Text)] -> IO ()
bindingHook Indicator s i
ind FrontEnd s i
front }) Binding s i
b FrontEnd s i
front

-- | Create an action appropriate for 'optBindingHook' in 'Option'
-- from 'Indicator' and 'FrontEnd'.
bindingHook :: Ord i => Indicator s1 i -> FrontEnd s2 i -> [(i, ActionDescription)] -> IO ()
bindingHook :: forall i s1 s2.
Ord i =>
Indicator s1 i -> FrontEnd s2 i -> [(i, Text)] -> IO ()
bindingHook Indicator s1 i
ind FrontEnd s2 i
front [(i, Text)]
bind_list = [i] -> (i -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Indicator s1 i -> [i]
forall s i. Indicator s i -> [i]
allButtons Indicator s1 i
ind) ((i -> IO ()) -> IO ()) -> (i -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \i
input -> do
  let desc :: Text
desc = Text -> i -> Map i Text -> Text
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault (FrontEnd s2 i -> i -> Text
forall s i. FrontEnd s i -> i -> Text
frontDefaultDescription FrontEnd s2 i
front i
input) i
input ([(i, Text)] -> Map i Text
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(i, Text)]
bind_list)
  Indicator s1 i -> i -> Text -> IO ()
forall s i. Indicator s i -> i -> Text -> IO ()
updateDescription Indicator s1 i
ind i
input Text
desc
                       
  
newNumPadWindow :: NumPadContext Window
newNumPadWindow :: NumPadContext Window
newNumPadWindow = do
  Window
win <- WindowType -> NumPadContext Window
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
WindowType -> m Window
windowNew WindowType
WindowTypeToplevel
  Window -> Bool -> ReaderT NumPadConfig IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWindow a) =>
a -> Bool -> m ()
windowSetKeepAbove Window
win Bool
True
  Window -> [AttrOp Window 'AttrSet] -> ReaderT NumPadConfig IO ()
forall o (m :: * -> *).
MonadIO m =>
o -> [AttrOp o 'AttrSet] -> m ()
GIAttr.set Window
win [ IsLabel "skipPagerHint" (AttrLabelProxy "skipPagerHint")
AttrLabelProxy "skipPagerHint"
#skipPagerHint AttrLabelProxy "skipPagerHint" -> Bool -> AttrOp Window 'AttrSet
forall obj info (attr :: Symbol) (tag :: AttrOpTag) b.
(HasAttributeList obj, info ~ ResolveAttribute attr obj,
 AttrInfo info, AttrBaseTypeConstraint info obj,
 AttrOpAllowed tag info obj, AttrSetTypeConstraint info b) =>
AttrLabelProxy attr -> b -> AttrOp obj tag
:= Bool
True,
                   #skipTaskbarHint := True,
                   #acceptFocus := False,
                   #focusOnMap := False
                 ]
  Window -> Text -> ReaderT NumPadConfig IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWindow a) =>
a -> Text -> m ()
windowSetTitle Window
win Text
"WildBind Description"
  Int32
win_x <- (Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int32) -> (NumPadConfig -> Int) -> NumPadConfig -> Int32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NumPadConfig -> Int
confWindowX) (NumPadConfig -> Int32)
-> ReaderT NumPadConfig IO NumPadConfig
-> ReaderT NumPadConfig IO Int32
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT NumPadConfig IO NumPadConfig
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  Int32
win_y <- (Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int32) -> (NumPadConfig -> Int) -> NumPadConfig -> Int32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NumPadConfig -> Int
confWindowY) (NumPadConfig -> Int32)
-> ReaderT NumPadConfig IO NumPadConfig
-> ReaderT NumPadConfig IO Int32
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT NumPadConfig IO NumPadConfig
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  Window -> Int32 -> Int32 -> ReaderT NumPadConfig IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWindow a) =>
a -> Int32 -> Int32 -> m ()
windowMove Window
win Int32
win_x Int32
win_y
  Window -> NumPadContext Window
forall (m :: * -> *) a. Monad m => a -> m a
return Window
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 :: forall i.
NumPadPosition i =>
NumPadContext (Table, i -> Text -> IO ())
newNumPadTable = do
  Table
tab <- Word32 -> Word32 -> Bool -> ReaderT NumPadConfig IO Table
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Word32 -> Word32 -> Bool -> m Table
tableNew Word32
5 Word32
4 Bool
False
  -- NumLock is unboundable, so it's treatd in a different way from others.
  (\Label
label -> Label -> Text -> ReaderT NumPadConfig IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsLabel a) =>
a -> Text -> m ()
labelSetText Label
label Text
"NumLock") (Label -> ReaderT NumPadConfig IO ())
-> ReaderT NumPadConfig IO Label -> ReaderT NumPadConfig IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Table
-> Word32
-> Word32
-> Word32
-> Word32
-> ReaderT NumPadConfig IO Label
addButton Table
tab Word32
0 Word32
1 Word32
0 Word32
1
  DescriptActionGetter NumPadLocked
descript_action_getter <-
    ([DescriptActionGetter NumPadLocked]
 -> DescriptActionGetter NumPadLocked)
-> ReaderT NumPadConfig IO [DescriptActionGetter NumPadLocked]
-> ReaderT NumPadConfig IO (DescriptActionGetter NumPadLocked)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [DescriptActionGetter NumPadLocked]
-> DescriptActionGetter NumPadLocked
forall a. Monoid a => [a] -> a
mconcat (ReaderT NumPadConfig IO [DescriptActionGetter NumPadLocked]
 -> ReaderT NumPadConfig IO (DescriptActionGetter NumPadLocked))
-> ReaderT NumPadConfig IO [DescriptActionGetter NumPadLocked]
-> ReaderT NumPadConfig IO (DescriptActionGetter NumPadLocked)
forall a b. (a -> b) -> a -> b
$ [ReaderT NumPadConfig IO (DescriptActionGetter NumPadLocked)]
-> ReaderT NumPadConfig IO [DescriptActionGetter NumPadLocked]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([ReaderT NumPadConfig IO (DescriptActionGetter NumPadLocked)]
 -> ReaderT NumPadConfig IO [DescriptActionGetter NumPadLocked])
-> [ReaderT NumPadConfig IO (DescriptActionGetter NumPadLocked)]
-> ReaderT NumPadConfig IO [DescriptActionGetter NumPadLocked]
forall a b. (a -> b) -> a -> b
$
      [ NumPadLocked
-> ReaderT NumPadConfig IO Label
-> ReaderT NumPadConfig IO (DescriptActionGetter NumPadLocked)
forall i.
Eq i =>
i
-> ReaderT NumPadConfig IO Label
-> NumPadContext (DescriptActionGetter i)
getter NumPadLocked
NumLDivide (ReaderT NumPadConfig IO Label
 -> ReaderT NumPadConfig IO (DescriptActionGetter NumPadLocked))
-> ReaderT NumPadConfig IO Label
-> ReaderT NumPadConfig IO (DescriptActionGetter NumPadLocked)
forall a b. (a -> b) -> a -> b
$ Table
-> Word32
-> Word32
-> Word32
-> Word32
-> ReaderT NumPadConfig IO Label
addButton Table
tab Word32
1 Word32
2 Word32
0 Word32
1,
        NumPadLocked
-> ReaderT NumPadConfig IO Label
-> ReaderT NumPadConfig IO (DescriptActionGetter NumPadLocked)
forall i.
Eq i =>
i
-> ReaderT NumPadConfig IO Label
-> NumPadContext (DescriptActionGetter i)
getter NumPadLocked
NumLMulti (ReaderT NumPadConfig IO Label
 -> ReaderT NumPadConfig IO (DescriptActionGetter NumPadLocked))
-> ReaderT NumPadConfig IO Label
-> ReaderT NumPadConfig IO (DescriptActionGetter NumPadLocked)
forall a b. (a -> b) -> a -> b
$ Table
-> Word32
-> Word32
-> Word32
-> Word32
-> ReaderT NumPadConfig IO Label
addButton Table
tab Word32
2 Word32
3 Word32
0 Word32
1,
        NumPadLocked
-> ReaderT NumPadConfig IO Label
-> ReaderT NumPadConfig IO (DescriptActionGetter NumPadLocked)
forall i.
Eq i =>
i
-> ReaderT NumPadConfig IO Label
-> NumPadContext (DescriptActionGetter i)
getter NumPadLocked
NumLMinus (ReaderT NumPadConfig IO Label
 -> ReaderT NumPadConfig IO (DescriptActionGetter NumPadLocked))
-> ReaderT NumPadConfig IO Label
-> ReaderT NumPadConfig IO (DescriptActionGetter NumPadLocked)
forall a b. (a -> b) -> a -> b
$ Table
-> Word32
-> Word32
-> Word32
-> Word32
-> ReaderT NumPadConfig IO Label
addButton Table
tab Word32
3 Word32
4 Word32
0 Word32
1,
        NumPadLocked
-> ReaderT NumPadConfig IO Label
-> ReaderT NumPadConfig IO (DescriptActionGetter NumPadLocked)
forall i.
Eq i =>
i
-> ReaderT NumPadConfig IO Label
-> NumPadContext (DescriptActionGetter i)
getter NumPadLocked
NumL7 (ReaderT NumPadConfig IO Label
 -> ReaderT NumPadConfig IO (DescriptActionGetter NumPadLocked))
-> ReaderT NumPadConfig IO Label
-> ReaderT NumPadConfig IO (DescriptActionGetter NumPadLocked)
forall a b. (a -> b) -> a -> b
$ Table
-> Word32
-> Word32
-> Word32
-> Word32
-> ReaderT NumPadConfig IO Label
addButton Table
tab Word32
0 Word32
1 Word32
1 Word32
2,
        NumPadLocked
-> ReaderT NumPadConfig IO Label
-> ReaderT NumPadConfig IO (DescriptActionGetter NumPadLocked)
forall i.
Eq i =>
i
-> ReaderT NumPadConfig IO Label
-> NumPadContext (DescriptActionGetter i)
getter NumPadLocked
NumL8 (ReaderT NumPadConfig IO Label
 -> ReaderT NumPadConfig IO (DescriptActionGetter NumPadLocked))
-> ReaderT NumPadConfig IO Label
-> ReaderT NumPadConfig IO (DescriptActionGetter NumPadLocked)
forall a b. (a -> b) -> a -> b
$ Table
-> Word32
-> Word32
-> Word32
-> Word32
-> ReaderT NumPadConfig IO Label
addButton Table
tab Word32
1 Word32
2 Word32
1 Word32
2,
        NumPadLocked
-> ReaderT NumPadConfig IO Label
-> ReaderT NumPadConfig IO (DescriptActionGetter NumPadLocked)
forall i.
Eq i =>
i
-> ReaderT NumPadConfig IO Label
-> NumPadContext (DescriptActionGetter i)
getter NumPadLocked
NumL9 (ReaderT NumPadConfig IO Label
 -> ReaderT NumPadConfig IO (DescriptActionGetter NumPadLocked))
-> ReaderT NumPadConfig IO Label
-> ReaderT NumPadConfig IO (DescriptActionGetter NumPadLocked)
forall a b. (a -> b) -> a -> b
$ Table
-> Word32
-> Word32
-> Word32
-> Word32
-> ReaderT NumPadConfig IO Label
addButton Table
tab Word32
2 Word32
3 Word32
1 Word32
2,
        NumPadLocked
-> ReaderT NumPadConfig IO Label
-> ReaderT NumPadConfig IO (DescriptActionGetter NumPadLocked)
forall i.
Eq i =>
i
-> ReaderT NumPadConfig IO Label
-> NumPadContext (DescriptActionGetter i)
getter NumPadLocked
NumLPlus (ReaderT NumPadConfig IO Label
 -> ReaderT NumPadConfig IO (DescriptActionGetter NumPadLocked))
-> ReaderT NumPadConfig IO Label
-> ReaderT NumPadConfig IO (DescriptActionGetter NumPadLocked)
forall a b. (a -> b) -> a -> b
$ Table
-> Word32
-> Word32
-> Word32
-> Word32
-> ReaderT NumPadConfig IO Label
addButton Table
tab Word32
3 Word32
4 Word32
1 Word32
3,
        NumPadLocked
-> ReaderT NumPadConfig IO Label
-> ReaderT NumPadConfig IO (DescriptActionGetter NumPadLocked)
forall i.
Eq i =>
i
-> ReaderT NumPadConfig IO Label
-> NumPadContext (DescriptActionGetter i)
getter NumPadLocked
NumL4 (ReaderT NumPadConfig IO Label
 -> ReaderT NumPadConfig IO (DescriptActionGetter NumPadLocked))
-> ReaderT NumPadConfig IO Label
-> ReaderT NumPadConfig IO (DescriptActionGetter NumPadLocked)
forall a b. (a -> b) -> a -> b
$ Table
-> Word32
-> Word32
-> Word32
-> Word32
-> ReaderT NumPadConfig IO Label
addButton Table
tab Word32
0 Word32
1 Word32
2 Word32
3,
        NumPadLocked
-> ReaderT NumPadConfig IO Label
-> ReaderT NumPadConfig IO (DescriptActionGetter NumPadLocked)
forall i.
Eq i =>
i
-> ReaderT NumPadConfig IO Label
-> NumPadContext (DescriptActionGetter i)
getter NumPadLocked
NumL5 (ReaderT NumPadConfig IO Label
 -> ReaderT NumPadConfig IO (DescriptActionGetter NumPadLocked))
-> ReaderT NumPadConfig IO Label
-> ReaderT NumPadConfig IO (DescriptActionGetter NumPadLocked)
forall a b. (a -> b) -> a -> b
$ Table
-> Word32
-> Word32
-> Word32
-> Word32
-> ReaderT NumPadConfig IO Label
addButton Table
tab Word32
1 Word32
2 Word32
2 Word32
3,
        NumPadLocked
-> ReaderT NumPadConfig IO Label
-> ReaderT NumPadConfig IO (DescriptActionGetter NumPadLocked)
forall i.
Eq i =>
i
-> ReaderT NumPadConfig IO Label
-> NumPadContext (DescriptActionGetter i)
getter NumPadLocked
NumL6 (ReaderT NumPadConfig IO Label
 -> ReaderT NumPadConfig IO (DescriptActionGetter NumPadLocked))
-> ReaderT NumPadConfig IO Label
-> ReaderT NumPadConfig IO (DescriptActionGetter NumPadLocked)
forall a b. (a -> b) -> a -> b
$ Table
-> Word32
-> Word32
-> Word32
-> Word32
-> ReaderT NumPadConfig IO Label
addButton Table
tab Word32
2 Word32
3 Word32
2 Word32
3,
        NumPadLocked
-> ReaderT NumPadConfig IO Label
-> ReaderT NumPadConfig IO (DescriptActionGetter NumPadLocked)
forall i.
Eq i =>
i
-> ReaderT NumPadConfig IO Label
-> NumPadContext (DescriptActionGetter i)
getter NumPadLocked
NumL1 (ReaderT NumPadConfig IO Label
 -> ReaderT NumPadConfig IO (DescriptActionGetter NumPadLocked))
-> ReaderT NumPadConfig IO Label
-> ReaderT NumPadConfig IO (DescriptActionGetter NumPadLocked)
forall a b. (a -> b) -> a -> b
$ Table
-> Word32
-> Word32
-> Word32
-> Word32
-> ReaderT NumPadConfig IO Label
addButton Table
tab Word32
0 Word32
1 Word32
3 Word32
4,
        NumPadLocked
-> ReaderT NumPadConfig IO Label
-> ReaderT NumPadConfig IO (DescriptActionGetter NumPadLocked)
forall i.
Eq i =>
i
-> ReaderT NumPadConfig IO Label
-> NumPadContext (DescriptActionGetter i)
getter NumPadLocked
NumL2 (ReaderT NumPadConfig IO Label
 -> ReaderT NumPadConfig IO (DescriptActionGetter NumPadLocked))
-> ReaderT NumPadConfig IO Label
-> ReaderT NumPadConfig IO (DescriptActionGetter NumPadLocked)
forall a b. (a -> b) -> a -> b
$ Table
-> Word32
-> Word32
-> Word32
-> Word32
-> ReaderT NumPadConfig IO Label
addButton Table
tab Word32
1 Word32
2 Word32
3 Word32
4,
        NumPadLocked
-> ReaderT NumPadConfig IO Label
-> ReaderT NumPadConfig IO (DescriptActionGetter NumPadLocked)
forall i.
Eq i =>
i
-> ReaderT NumPadConfig IO Label
-> NumPadContext (DescriptActionGetter i)
getter NumPadLocked
NumL3 (ReaderT NumPadConfig IO Label
 -> ReaderT NumPadConfig IO (DescriptActionGetter NumPadLocked))
-> ReaderT NumPadConfig IO Label
-> ReaderT NumPadConfig IO (DescriptActionGetter NumPadLocked)
forall a b. (a -> b) -> a -> b
$ Table
-> Word32
-> Word32
-> Word32
-> Word32
-> ReaderT NumPadConfig IO Label
addButton Table
tab Word32
2 Word32
3 Word32
3 Word32
4,
        NumPadLocked
-> ReaderT NumPadConfig IO Label
-> ReaderT NumPadConfig IO (DescriptActionGetter NumPadLocked)
forall i.
Eq i =>
i
-> ReaderT NumPadConfig IO Label
-> NumPadContext (DescriptActionGetter i)
getter NumPadLocked
NumLEnter (ReaderT NumPadConfig IO Label
 -> ReaderT NumPadConfig IO (DescriptActionGetter NumPadLocked))
-> ReaderT NumPadConfig IO Label
-> ReaderT NumPadConfig IO (DescriptActionGetter NumPadLocked)
forall a b. (a -> b) -> a -> b
$ Table
-> Word32
-> Word32
-> Word32
-> Word32
-> ReaderT NumPadConfig IO Label
addButton Table
tab Word32
3 Word32
4 Word32
3 Word32
5,
        NumPadLocked
-> ReaderT NumPadConfig IO Label
-> ReaderT NumPadConfig IO (DescriptActionGetter NumPadLocked)
forall i.
Eq i =>
i
-> ReaderT NumPadConfig IO Label
-> NumPadContext (DescriptActionGetter i)
getter NumPadLocked
NumL0 (ReaderT NumPadConfig IO Label
 -> ReaderT NumPadConfig IO (DescriptActionGetter NumPadLocked))
-> ReaderT NumPadConfig IO Label
-> ReaderT NumPadConfig IO (DescriptActionGetter NumPadLocked)
forall a b. (a -> b) -> a -> b
$ Table
-> Word32
-> Word32
-> Word32
-> Word32
-> ReaderT NumPadConfig IO Label
addButton Table
tab Word32
0 Word32
2 Word32
4 Word32
5,
        NumPadLocked
-> ReaderT NumPadConfig IO Label
-> ReaderT NumPadConfig IO (DescriptActionGetter NumPadLocked)
forall i.
Eq i =>
i
-> ReaderT NumPadConfig IO Label
-> NumPadContext (DescriptActionGetter i)
getter NumPadLocked
NumLPeriod (ReaderT NumPadConfig IO Label
 -> ReaderT NumPadConfig IO (DescriptActionGetter NumPadLocked))
-> ReaderT NumPadConfig IO Label
-> ReaderT NumPadConfig IO (DescriptActionGetter NumPadLocked)
forall a b. (a -> b) -> a -> b
$ Table
-> Word32
-> Word32
-> Word32
-> Word32
-> ReaderT NumPadConfig IO Label
addButton Table
tab Word32
2 Word32
3 Word32
4 Word32
5
      ]
  let description_updater :: i -> Text -> IO ()
description_updater = \i
input -> case DescriptActionGetter NumPadLocked
descript_action_getter DescriptActionGetter NumPadLocked
-> DescriptActionGetter NumPadLocked
forall a b. (a -> b) -> a -> b
$ i -> NumPadLocked
forall a. NumPadPosition a => a -> NumPadLocked
toNumPad i
input of
        First (Just Text -> IO ()
act) -> Text -> IO ()
act
        First Maybe (Text -> IO ())
Nothing -> IO () -> Text -> IO ()
forall a b. a -> b -> a
const (IO () -> Text -> IO ()) -> IO () -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  (Table, i -> Text -> IO ())
-> NumPadContext (Table, i -> Text -> IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Table
tab, i -> Text -> IO ()
description_updater)
  where
    getter :: Eq i => i -> NumPadContext Label -> NumPadContext (DescriptActionGetter i)
    getter :: forall i.
Eq i =>
i
-> ReaderT NumPadConfig IO Label
-> NumPadContext (DescriptActionGetter i)
getter i
bound_key ReaderT NumPadConfig IO Label
get_label = do
      Label
label <- ReaderT NumPadConfig IO Label
get_label
      DescriptActionGetter i -> NumPadContext (DescriptActionGetter i)
forall (m :: * -> *) a. Monad m => a -> m a
return (DescriptActionGetter i -> NumPadContext (DescriptActionGetter i))
-> DescriptActionGetter i -> NumPadContext (DescriptActionGetter i)
forall a b. (a -> b) -> a -> b
$ \i
in_key -> Maybe (Text -> IO ()) -> First (Text -> IO ())
forall a. Maybe a -> First a
First (if i
in_key i -> i -> Bool
forall a. Eq a => a -> a -> Bool
== i
bound_key then (Text -> IO ()) -> Maybe (Text -> IO ())
forall a. a -> Maybe a
Just ((Text -> IO ()) -> Maybe (Text -> IO ()))
-> (Text -> IO ()) -> Maybe (Text -> IO ())
forall a b. (a -> b) -> a -> b
$ Label -> Text -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsLabel a) =>
a -> Text -> m ()
labelSetText Label
label else Maybe (Text -> IO ())
forall a. Maybe a
Nothing)

addButton :: Table -> Word32 -> Word32 -> Word32 -> Word32 -> NumPadContext Label
addButton :: Table
-> Word32
-> Word32
-> Word32
-> Word32
-> ReaderT NumPadConfig IO Label
addButton Table
tab Word32
left Word32
right Word32
top Word32
bottom = do
  Label
lab <- Maybe Text -> ReaderT NumPadConfig IO Label
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Maybe Text -> m Label
labelNew Maybe Text
forall a. Maybe a
Nothing
  Label -> Bool -> ReaderT NumPadConfig IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsLabel a) =>
a -> Bool -> m ()
labelSetLineWrap Label
lab Bool
True
  Label -> Float -> Float -> ReaderT NumPadConfig IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsMisc a) =>
a -> Float -> Float -> m ()
miscSetAlignment Label
lab Float
0 Float
0.5
  Label -> Justification -> ReaderT NumPadConfig IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsLabel a) =>
a -> Justification -> m ()
labelSetJustify Label
lab Justification
JustificationLeft
  Button
button <- ReaderT NumPadConfig IO Button
forall (m :: * -> *). (HasCallStack, MonadIO m) => m Button
buttonNew
  Button -> Float -> Float -> ReaderT NumPadConfig IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsButton a) =>
a -> Float -> Float -> m ()
buttonSetAlignment Button
button Float
0 Float
0.5
  Button -> Label -> ReaderT NumPadConfig IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsContainer a, IsWidget b) =>
a -> b -> m ()
containerAdd Button
button Label
lab
  Table
-> Button
-> Word32
-> Word32
-> Word32
-> Word32
-> ReaderT NumPadConfig IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsTable a, IsWidget b) =>
a -> b -> Word32 -> Word32 -> Word32 -> Word32 -> m ()
tableAttachDefaults Table
tab Button
button Word32
left Word32
right Word32
top Word32
bottom
  Int32
bw <- (Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int32) -> (NumPadConfig -> Int) -> NumPadConfig -> Int32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NumPadConfig -> Int
confButtonWidth) (NumPadConfig -> Int32)
-> ReaderT NumPadConfig IO NumPadConfig
-> ReaderT NumPadConfig IO Int32
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT NumPadConfig IO NumPadConfig
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  Int32
bh <- (Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int32) -> (NumPadConfig -> Int) -> NumPadConfig -> Int32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NumPadConfig -> Int
confButtonHeight) (NumPadConfig -> Int32)
-> ReaderT NumPadConfig IO NumPadConfig
-> ReaderT NumPadConfig IO Int32
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT NumPadConfig IO NumPadConfig
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  Label -> Int32 -> Int32 -> ReaderT NumPadConfig IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> Int32 -> Int32 -> m ()
widgetSetSizeRequest Label
lab (Int32
bw Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
* Word32 -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32
right Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
- Word32
left)) (Int32
bh Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
* Word32 -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32
bottom Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
- Word32
top))
  Label -> ReaderT NumPadConfig IO Label
forall (m :: * -> *) a. Monad m => a -> m a
return Label
lab

makeStatusMenu :: Indicator s i -> IO Menu
makeStatusMenu :: forall s i. Indicator s i -> IO Menu
makeStatusMenu Indicator s i
ind = IO Menu
impl where
  impl :: IO Menu
impl = do
    Menu
menu <- IO Menu
forall (m :: * -> *). (HasCallStack, MonadIO m) => m Menu
menuNew
    Menu -> MenuItem -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsContainer a, IsWidget b) =>
a -> b -> m ()
containerAdd Menu
menu (MenuItem -> IO ()) -> IO MenuItem -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO MenuItem
makeQuitItem
    Menu -> CheckMenuItem -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsContainer a, IsWidget b) =>
a -> b -> m ()
containerAdd Menu
menu (CheckMenuItem -> IO ()) -> IO CheckMenuItem -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO CheckMenuItem
makeToggler
    Menu -> IO Menu
forall (m :: * -> *) a. Monad m => a -> m a
return Menu
menu
  makeQuitItem :: IO MenuItem
makeQuitItem = do
    MenuItem
quit_item <- Text -> IO MenuItem
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Text -> m MenuItem
menuItemNewWithMnemonic Text
"_Quit"
    MenuItem -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
widgetShowAll MenuItem
quit_item
    IO SignalHandlerId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO SignalHandlerId -> IO ()) -> IO SignalHandlerId -> IO ()
forall a b. (a -> b) -> a -> b
$ MenuItem
-> SignalProxy MenuItem MenuItemActivateSignalInfo
-> HaskellCallbackType MenuItemActivateSignalInfo
-> IO SignalHandlerId
forall object info (m :: * -> *).
(GObject object, MonadIO m, SignalInfo info) =>
object
-> SignalProxy object info
-> HaskellCallbackType info
-> m SignalHandlerId
GIAttr.on MenuItem
quit_item IsLabel
  "activate" (SignalProxy MenuItem MenuItemActivateSignalInfo)
SignalProxy MenuItem MenuItemActivateSignalInfo
#activate (Indicator s i -> IO ()
forall s i. Indicator s i -> IO ()
quit Indicator s i
ind)
    MenuItem -> IO MenuItem
forall (m :: * -> *) a. Monad m => a -> m a
return MenuItem
quit_item
  makeToggler :: IO CheckMenuItem
makeToggler = do
    CheckMenuItem
toggler <- Text -> IO CheckMenuItem
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Text -> m CheckMenuItem
checkMenuItemNewWithMnemonic Text
"_Toggle description"
    CheckMenuItem -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
widgetShowAll CheckMenuItem
toggler
    CheckMenuItem -> Bool -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsCheckMenuItem a) =>
a -> Bool -> m ()
checkMenuItemSetActive CheckMenuItem
toggler (Bool -> IO ()) -> IO Bool -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Indicator s i -> IO Bool
forall s i. Indicator s i -> IO Bool
getPresence Indicator s i
ind
    IO SignalHandlerId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO SignalHandlerId -> IO ()) -> IO SignalHandlerId -> IO ()
forall a b. (a -> b) -> a -> b
$ CheckMenuItem
-> SignalProxy CheckMenuItem CheckMenuItemToggledSignalInfo
-> HaskellCallbackType CheckMenuItemToggledSignalInfo
-> IO SignalHandlerId
forall object info (m :: * -> *).
(GObject object, MonadIO m, SignalInfo info) =>
object
-> SignalProxy object info
-> HaskellCallbackType info
-> m SignalHandlerId
GIAttr.on CheckMenuItem
toggler IsLabel
  "toggled"
  (SignalProxy CheckMenuItem CheckMenuItemToggledSignalInfo)
SignalProxy CheckMenuItem CheckMenuItemToggledSignalInfo
#toggled (Indicator s i -> IO ()
forall s i. Indicator s i -> IO ()
togglePresence Indicator s i
ind)
    CheckMenuItem -> IO CheckMenuItem
forall (m :: * -> *) a. Monad m => a -> m a
return CheckMenuItem
toggler

-- | Map input type of 'Indicator', so that it can adapt to the new
-- input type @i'@.
--
-- If the contra-mapper function returns 'Nothing', those input
-- symbols are ignored by the 'Indicator'.
--
-- @since 0.2.0.0
adaptIndicator :: (i -> i') -- ^ mapper function
               -> (i' -> Maybe i) -- ^ contra-mapper function
               -> Indicator s i -- ^ original
               -> Indicator s i' -- ^ adapted indicator
adaptIndicator :: forall i i' s.
(i -> i') -> (i' -> Maybe i) -> Indicator s i -> Indicator s i'
adaptIndicator i -> i'
mapper i' -> Maybe i
cmapper Indicator s i
ind =
  Indicator s i
ind { updateDescription :: i' -> Text -> IO ()
updateDescription = i' -> Text -> IO ()
newDesc,
        allButtons :: [i']
allButtons = (i -> i') -> [i] -> [i']
forall a b. (a -> b) -> [a] -> [b]
map i -> i'
mapper ([i] -> [i']) -> [i] -> [i']
forall a b. (a -> b) -> a -> b
$ Indicator s i -> [i]
forall s i. Indicator s i -> [i]
allButtons Indicator s i
ind
      }
  where
    newDesc :: i' -> Text -> IO ()
newDesc i'
input = case i' -> Maybe i
cmapper i'
input of
      Maybe i
Nothing -> IO () -> Text -> IO ()
forall a b. a -> b -> a
const (IO () -> Text -> IO ()) -> IO () -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Just i
orig_input -> Indicator s i -> i -> Text -> IO ()
forall s i. Indicator s i -> i -> Text -> IO ()
updateDescription Indicator s i
ind i
orig_input

-- | A binding that toggles presence of the 'Indicator'.
--
-- @since 0.2.0.0
toggleBinding :: (NumPadPosition i, Ord i, Enum i, Bounded i)
              => Indicator s i
              -> NumPadLocked -- ^ the button to bind the 'togglePresence' action
              -> Binding' bs fs i
toggleBinding :: forall i s bs fs.
(NumPadPosition i, Ord i, Enum i, Bounded i) =>
Indicator s i -> NumPadLocked -> Binding' bs fs i
toggleBinding Indicator s i
ind NumPadLocked
button = [(i, Action IO ())] -> Binding' bs fs i
forall i r bs fs. Ord i => [(i, Action IO r)] -> Binding' bs fs i
binding ([(i, Action IO ())] -> Binding' bs fs i)
-> [(i, Action IO ())] -> Binding' bs fs i
forall a b. (a -> b) -> a -> b
$ (i -> (i, Action IO ())) -> [i] -> [(i, Action IO ())]
forall a b. (a -> b) -> [a] -> [b]
map (\i
input -> (i
input, Text -> IO () -> Action IO ()
forall (m :: * -> *) a. Text -> m a -> Action m a
Action Text
"Toggle description" (IO () -> Action IO ()) -> IO () -> Action IO ()
forall a b. (a -> b) -> a -> b
$ Indicator s i -> IO ()
forall s i. Indicator s i -> IO ()
togglePresence Indicator s i
ind)) [i]
help_likes
  where
    help_likes :: [i]
help_likes = (i -> Bool) -> [i] -> [i]
forall a. (a -> Bool) -> [a] -> [a]
filter ((NumPadLocked -> NumPadLocked -> Bool
forall a. Eq a => a -> a -> Bool
== NumPadLocked
button) (NumPadLocked -> Bool) -> (i -> NumPadLocked) -> i -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. i -> NumPadLocked
forall a. NumPadPosition a => a -> NumPadLocked
toNumPad) ([i] -> [i]) -> [i] -> [i]
forall a b. (a -> b) -> a -> b
$ i -> i -> [i]
forall a. Enum a => a -> a -> [a]
enumFromTo i
forall a. Bounded a => a
minBound i
forall a. Bounded a => a
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 :: IO () -> IO ()
postGUIAsync IO ()
action = IO Word32 -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Word32 -> IO ()) -> IO Word32 -> IO ()
forall a b. (a -> b) -> a -> b
$ Int32 -> IO Bool -> IO Word32
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Int32 -> IO Bool -> m Word32
threadsAddIdle Int32
PRIORITY_DEFAULT (IO ()
action IO () -> IO Bool -> IO Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False)

-- | Similar to 'postGUIAsync', but this function waits for the action
-- to finish.
postGUISync :: IO a -> IO a
postGUISync :: forall a. IO a -> IO a
postGUISync IO a
action = do
  MVar a
mret <- IO (MVar a)
forall a. IO (MVar a)
newEmptyMVar
  IO () -> IO ()
postGUIAsync (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    a
ret <- IO a
action
    MVar a -> a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar a
mret a
ret
  MVar a -> IO a
forall a. MVar a -> IO a
takeMVar MVar a
mret