{-# LANGUAGE OverloadedStrings, OverloadedLabels, PatternSynonyms #-}
module WildBind.Indicator
(
withNumPadIndicator,
wildBindWithIndicator,
bindingHook,
Indicator,
updateDescription,
getPresence,
setPresence,
togglePresence,
quit,
adaptIndicator,
toggleBinding,
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)
import GI.Gdk.Functions (threadsAddIdle)
import GI.GLib.Constants (pattern PRIORITY_DEFAULT)
import GI.Gtk
(
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
)
data Indicator s i =
Indicator
{ forall s i. Indicator s i -> i -> Text -> IO ()
updateDescription :: i -> ActionDescription -> IO (),
forall s i. Indicator s i -> IO Bool
getPresence :: IO Bool,
forall s i. Indicator s i -> Bool -> IO ()
setPresence :: Bool -> IO (),
forall s i. Indicator s i -> IO ()
quit :: IO (),
forall s i. Indicator s i -> [i]
allButtons :: [i]
}
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
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
}
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 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
}
type NumPadContext = ReaderT NumPadConfig IO
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
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
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
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
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
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
(\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
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
adaptIndicator :: (i -> i')
-> (i' -> Maybe i)
-> Indicator s i
-> Indicator s i'
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
toggleBinding :: (NumPadPosition i, Ord i, Enum i, Bounded i)
=> Indicator s i
-> NumPadLocked
-> 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
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)
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