-----------------------------------------------------------------------------
-- |
-- Module      : System.Taffybar.Widget.XDGMenu.MenuWidget
-- Copyright   : 2017 Ulf Jasper
-- License     : BSD3-style (see LICENSE)
--
-- Maintainer  : Ulf Jasper <ulf.jasper@web.de>
-- Stability   : unstable
-- Portability : unportable
--
-- MenuWidget provides a hierachical GTK menu containing all
-- applicable desktop entries found on the system.  The menu is built
-- according to the version 1.1 of the XDG "Desktop Menu
-- Specification", see
-- https://specifications.freedesktop.org/menu-spec/menu-spec-1.1.html
-----------------------------------------------------------------------------

module System.Taffybar.Widget.XDGMenu.MenuWidget
  (
  -- * Usage
  -- $usage
  menuWidgetNew
  )
where

import           Control.Monad
import           Control.Monad.IO.Class
import qualified Data.Text as T
import           GI.Gtk hiding (Menu, imageMenuItemNew)
import           System.Log.Logger
import           System.Process
import           System.Taffybar.Widget.Generic.AutoSizeImage
import           System.Taffybar.Widget.Util
import           System.Taffybar.Widget.XDGMenu.Menu

-- $usage
--
-- In order to use this widget add the following line to your
-- @taffybar.hs@ file:
--
-- > import System.Taffybar.Widget.XDGMenu.MenuWidget
-- > main = do
-- >   let menu = menuWidgetNew $ Just "PREFIX-"
--
-- The menu will look for a file named "PREFIX-applications.menu" in the
-- (subdirectory "menus" of the) directories specified by the environment
-- variables XDG_CONFIG_HOME and XDG_CONFIG_DIRS. (If XDG_CONFIG_HOME is not set
-- or empty then $HOME/.config is used, if XDG_CONFIG_DIRS is not set or empty
-- then "/etc/xdg" is used). If no prefix is given (i.e. if you pass Nothing)
-- then the value of the environment variable XDG_MENU_PREFIX is used, if it is
-- set. If taffybar is running inside a desktop environment like Mate, Gnome,
-- XFCE etc. the environment variables XDG_CONFIG_DIRS and XDG_MENU_PREFIX
-- should be set and you may create the menu like this:
--
-- >   let menu = menuWidgetNew Nothing
--
-- Now you can use @menu@ as any other Taffybar widget.

logHere :: Priority -> String -> IO ()
logHere :: Priority -> String -> IO ()
logHere = String -> Priority -> String -> IO ()
logM String
"System.Taffybar.Widget.XDGMenu.MenuWidget"

-- | Add a desktop entry to a gtk menu by appending a gtk menu item.
addItem :: (IsMenuShell msc) =>
           msc -- ^ GTK menu
        -> MenuEntry -- ^ Desktop entry
        -> IO ()
addItem :: forall msc. IsMenuShell msc => msc -> MenuEntry -> IO ()
addItem msc
ms MenuEntry
de = do
  MenuItem
item <- Text -> (Int32 -> IO (Maybe Pixbuf)) -> IO MenuItem
forall (m :: * -> *).
MonadIO m =>
Text -> (Int32 -> IO (Maybe Pixbuf)) -> m MenuItem
imageMenuItemNew (MenuEntry -> Text
feName MenuEntry
de) (Maybe Text -> Int32 -> IO (Maybe Pixbuf)
getImageForMaybeIconName (MenuEntry -> Maybe Text
feIcon MenuEntry
de))
  MenuItem -> Text -> IO ()
forall (m :: * -> *) o.
(MonadIO m, IsWidget o) =>
o -> Text -> m ()
setWidgetTooltipText MenuItem
item (MenuEntry -> Text
feComment MenuEntry
de)
  msc -> MenuItem -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsMenuShell a, IsMenuItem b) =>
a -> b -> m ()
menuShellAppend msc
ms MenuItem
item
  SignalHandlerId
_ <- MenuItem -> ((?self::MenuItem) => IO ()) -> IO SignalHandlerId
forall a (m :: * -> *).
(IsMenuItem a, MonadIO m) =>
a -> ((?self::a) => IO ()) -> m SignalHandlerId
onMenuItemActivate MenuItem
item (((?self::MenuItem) => IO ()) -> IO SignalHandlerId)
-> ((?self::MenuItem) => IO ()) -> IO SignalHandlerId
forall a b. (a -> b) -> a -> b
$ do
    let cmd :: String
cmd = MenuEntry -> String
feCommand MenuEntry
de
    Priority -> String -> IO ()
logHere Priority
DEBUG (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Launching '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cmd String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'"
    ProcessHandle
_ <- String -> IO ProcessHandle
spawnCommand String
cmd
    () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Add an xdg menu to a gtk menu by appending gtk menu items and submenus.
addMenu
  :: (IsMenuShell msc)
  => msc -- ^ A GTK menu
  -> Menu -- ^ A menu object
  -> IO ()
addMenu :: forall msc. IsMenuShell msc => msc -> Menu -> IO ()
addMenu msc
ms Menu
fm = do
  let subMenus :: [Menu]
subMenus = Menu -> [Menu]
fmSubmenus Menu
fm
      items :: [MenuEntry]
items = Menu -> [MenuEntry]
fmEntries Menu
fm
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not ([MenuEntry] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [MenuEntry]
items) Bool -> Bool -> Bool
|| Bool -> Bool
not ([Menu] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Menu]
subMenus)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    MenuItem
item <- Text -> (Int32 -> IO (Maybe Pixbuf)) -> IO MenuItem
forall (m :: * -> *).
MonadIO m =>
Text -> (Int32 -> IO (Maybe Pixbuf)) -> m MenuItem
imageMenuItemNew (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Menu -> String
fmName Menu
fm)
            (Maybe Text -> Int32 -> IO (Maybe Pixbuf)
getImageForMaybeIconName (String -> Text
T.pack (String -> Text) -> Maybe String -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Menu -> Maybe String
fmIcon Menu
fm))
    msc -> MenuItem -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsMenuShell a, IsMenuItem b) =>
a -> b -> m ()
menuShellAppend msc
ms MenuItem
item
    Menu
subMenu <- IO Menu
forall (m :: * -> *). (HasCallStack, MonadIO m) => m Menu
menuNew
    MenuItem -> Maybe Menu -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsMenuItem a, IsMenu b) =>
a -> Maybe b -> m ()
menuItemSetSubmenu MenuItem
item (Menu -> Maybe Menu
forall a. a -> Maybe a
Just Menu
subMenu)
    (Menu -> IO ()) -> [Menu] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Menu -> Menu -> IO ()
forall msc. IsMenuShell msc => msc -> Menu -> IO ()
addMenu Menu
subMenu) [Menu]
subMenus
    (MenuEntry -> IO ()) -> [MenuEntry] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Menu -> MenuEntry -> IO ()
forall msc. IsMenuShell msc => msc -> MenuEntry -> IO ()
addItem Menu
subMenu) [MenuEntry]
items

-- | Create a new XDG Menu Widget.
menuWidgetNew
  :: MonadIO m
  => Maybe String -- ^ menu name, must end with a dash, e.g. "mate-" or "gnome-"
  -> m GI.Gtk.Widget
menuWidgetNew :: forall (m :: * -> *). MonadIO m => Maybe String -> m Widget
menuWidgetNew Maybe String
mMenuPrefix = IO Widget -> m Widget
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Widget -> m Widget) -> IO Widget -> m Widget
forall a b. (a -> b) -> a -> b
$ do
  MenuBar
mb <- IO MenuBar
forall (m :: * -> *). (HasCallStack, MonadIO m) => m MenuBar
menuBarNew
  Menu
m <- Maybe String -> IO Menu
buildMenu Maybe String
mMenuPrefix
  MenuBar -> Menu -> IO ()
forall msc. IsMenuShell msc => msc -> Menu -> IO ()
addMenu MenuBar
mb Menu
m
  MenuBar -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
widgetShowAll MenuBar
mb
  MenuBar -> IO Widget
forall (m :: * -> *) o. (MonadIO m, IsWidget o) => o -> m Widget
toWidget MenuBar
mb