-----------------------------------------------------------------------------
-- |
-- Module      : System.Taffybar.Widget.XDGMenu.Menu
-- Copyright   : 2017 Ulf Jasper
-- License     : BSD3-style (see LICENSE)
--
-- Maintainer  : Ulf Jasper <ulf.jasper@web.de>
-- Stability   : unstable
-- Portability : unportable
--
-- Implementation of version 1.1 of the freedesktop "Desktop Menu
-- Specification", see
-- https://specifications.freedesktop.org/menu-spec/menu-spec-1.1.html
--
-- See also 'MenuWidget'.
-----------------------------------------------------------------------------

module System.Taffybar.Widget.XDGMenu.Menu
  ( Menu(..)
  , MenuEntry(..)
  , buildMenu
  , getApplicationEntries
  ) where

import Data.Char (toLower)
import Data.List
import Data.Maybe
import qualified Data.Text as T
import System.Environment.XDG.DesktopEntry
import System.Taffybar.Information.XDG.Protocol

-- | Displayable menu
data Menu = Menu
  { Menu -> String
fmName :: String
  , Menu -> String
fmComment :: String
  , Menu -> Maybe String
fmIcon :: Maybe String
  , Menu -> [Menu]
fmSubmenus :: [Menu]
  , Menu -> [MenuEntry]
fmEntries :: [MenuEntry]
  , Menu -> Bool
fmOnlyUnallocated :: Bool
  } deriving (Menu -> Menu -> Bool
(Menu -> Menu -> Bool) -> (Menu -> Menu -> Bool) -> Eq Menu
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Menu -> Menu -> Bool
== :: Menu -> Menu -> Bool
$c/= :: Menu -> Menu -> Bool
/= :: Menu -> Menu -> Bool
Eq, Int -> Menu -> ShowS
[Menu] -> ShowS
Menu -> String
(Int -> Menu -> ShowS)
-> (Menu -> String) -> ([Menu] -> ShowS) -> Show Menu
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Menu -> ShowS
showsPrec :: Int -> Menu -> ShowS
$cshow :: Menu -> String
show :: Menu -> String
$cshowList :: [Menu] -> ShowS
showList :: [Menu] -> ShowS
Show)

-- | Displayable menu entry
data MenuEntry = MenuEntry
  { MenuEntry -> Text
feName :: T.Text
  , MenuEntry -> Text
feComment :: T.Text
  , MenuEntry -> String
feCommand :: String
  , MenuEntry -> Maybe Text
feIcon :: Maybe T.Text
  } deriving (MenuEntry -> MenuEntry -> Bool
(MenuEntry -> MenuEntry -> Bool)
-> (MenuEntry -> MenuEntry -> Bool) -> Eq MenuEntry
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MenuEntry -> MenuEntry -> Bool
== :: MenuEntry -> MenuEntry -> Bool
$c/= :: MenuEntry -> MenuEntry -> Bool
/= :: MenuEntry -> MenuEntry -> Bool
Eq, Int -> MenuEntry -> ShowS
[MenuEntry] -> ShowS
MenuEntry -> String
(Int -> MenuEntry -> ShowS)
-> (MenuEntry -> String)
-> ([MenuEntry] -> ShowS)
-> Show MenuEntry
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MenuEntry -> ShowS
showsPrec :: Int -> MenuEntry -> ShowS
$cshow :: MenuEntry -> String
show :: MenuEntry -> String
$cshowList :: [MenuEntry] -> ShowS
showList :: [MenuEntry] -> ShowS
Show)

-- | Fetch menus and desktop entries and assemble the menu.
buildMenu :: Maybe String -> IO Menu
buildMenu :: Maybe String -> IO Menu
buildMenu Maybe String
mMenuPrefix = do
  Maybe (XDGMenu, [DesktopEntry])
mMenuDes <- Maybe String -> IO (Maybe (XDGMenu, [DesktopEntry]))
readXDGMenu Maybe String
mMenuPrefix
  case Maybe (XDGMenu, [DesktopEntry])
mMenuDes of
    Maybe (XDGMenu, [DesktopEntry])
Nothing -> Menu -> IO Menu
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Menu -> IO Menu) -> Menu -> IO Menu
forall a b. (a -> b) -> a -> b
$ String
-> String -> Maybe String -> [Menu] -> [MenuEntry] -> Bool -> Menu
Menu String
"???" String
"Parsing failed" Maybe String
forall a. Maybe a
Nothing [] [] Bool
False
    Just (XDGMenu
menu, [DesktopEntry]
des) -> do
      String
dt <- IO String
getXDGDesktop
      [String]
dirDirs <- IO [String]
getDirectoryDirs
      [String]
langs <- IO [String]
getPreferredLanguages
      (Menu
fm, [MenuEntry]
ae) <- String
-> [String]
-> [String]
-> [DesktopEntry]
-> XDGMenu
-> IO (Menu, [MenuEntry])
xdgToMenu String
dt [String]
langs [String]
dirDirs [DesktopEntry]
des XDGMenu
menu
      let fm' :: Menu
fm' = [MenuEntry] -> Menu -> Menu
fixOnlyUnallocated [MenuEntry]
ae Menu
fm
      Menu -> IO Menu
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Menu
fm'

-- | Convert xdg menu to displayable menu
xdgToMenu
  :: String
  -> [String]
  -> [FilePath]
  -> [DesktopEntry]
  -> XDGMenu
  -> IO (Menu, [MenuEntry])
xdgToMenu :: String
-> [String]
-> [String]
-> [DesktopEntry]
-> XDGMenu
-> IO (Menu, [MenuEntry])
xdgToMenu String
desktop [String]
langs [String]
dirDirs [DesktopEntry]
des XDGMenu
xm = do
  Maybe DesktopEntry
dirEntry <- [String] -> String -> IO (Maybe DesktopEntry)
getDirectoryEntry [String]
dirDirs (XDGMenu -> String
xmDirectory XDGMenu
xm)
  [(Menu, [MenuEntry])]
mas <- (XDGMenu -> IO (Menu, [MenuEntry]))
-> [XDGMenu] -> IO [(Menu, [MenuEntry])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (String
-> [String]
-> [String]
-> [DesktopEntry]
-> XDGMenu
-> IO (Menu, [MenuEntry])
xdgToMenu String
desktop [String]
langs [String]
dirDirs [DesktopEntry]
des) (XDGMenu -> [XDGMenu]
xmSubmenus XDGMenu
xm)
  let ([Menu]
menus, [[MenuEntry]]
subaes) = [(Menu, [MenuEntry])] -> ([Menu], [[MenuEntry]])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Menu, [MenuEntry])]
mas
      menus' :: [Menu]
menus' = (Menu -> Menu -> Ordering) -> [Menu] -> [Menu]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (\Menu
fm1 Menu
fm2 -> String -> String -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ((Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Menu -> String
fmName Menu
fm1)
                                   ((Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Menu -> String
fmName Menu
fm2)) [Menu]
menus
      entries :: [MenuEntry]
entries = (DesktopEntry -> MenuEntry) -> [DesktopEntry] -> [MenuEntry]
forall a b. (a -> b) -> [a] -> [b]
map ([String] -> DesktopEntry -> MenuEntry
xdgToMenuEntry [String]
langs) ([DesktopEntry] -> [MenuEntry]) -> [DesktopEntry] -> [MenuEntry]
forall a b. (a -> b) -> a -> b
$
                -- hide NoDisplay
                (DesktopEntry -> Bool) -> [DesktopEntry] -> [DesktopEntry]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (DesktopEntry -> Bool) -> DesktopEntry -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DesktopEntry -> Bool
deNoDisplay) ([DesktopEntry] -> [DesktopEntry])
-> [DesktopEntry] -> [DesktopEntry]
forall a b. (a -> b) -> a -> b
$
                -- onlyshowin
                (DesktopEntry -> Bool) -> [DesktopEntry] -> [DesktopEntry]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> DesktopEntry -> Bool
matchesOnlyShowIn String
desktop) ([DesktopEntry] -> [DesktopEntry])
-> [DesktopEntry] -> [DesktopEntry]
forall a b. (a -> b) -> a -> b
$
                -- excludes
                (DesktopEntry -> Bool) -> [DesktopEntry] -> [DesktopEntry]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (DesktopEntry -> Bool) -> DesktopEntry -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DesktopEntry -> DesktopEntryCondition -> Bool)
-> DesktopEntryCondition -> DesktopEntry -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip DesktopEntry -> DesktopEntryCondition -> Bool
matchesCondition (DesktopEntryCondition
-> Maybe DesktopEntryCondition -> DesktopEntryCondition
forall a. a -> Maybe a -> a
fromMaybe DesktopEntryCondition
None (XDGMenu -> Maybe DesktopEntryCondition
xmExclude XDGMenu
xm))) ([DesktopEntry] -> [DesktopEntry])
-> [DesktopEntry] -> [DesktopEntry]
forall a b. (a -> b) -> a -> b
$
                -- includes
                (DesktopEntry -> Bool) -> [DesktopEntry] -> [DesktopEntry]
forall a. (a -> Bool) -> [a] -> [a]
filter (DesktopEntry -> DesktopEntryCondition -> Bool
`matchesCondition` DesktopEntryCondition
-> Maybe DesktopEntryCondition -> DesktopEntryCondition
forall a. a -> Maybe a -> a
fromMaybe DesktopEntryCondition
None (XDGMenu -> Maybe DesktopEntryCondition
xmInclude XDGMenu
xm)) [DesktopEntry]
des
      onlyUnallocated :: Bool
onlyUnallocated = XDGMenu -> Bool
xmOnlyUnallocated XDGMenu
xm
      aes :: [MenuEntry]
aes = if Bool
onlyUnallocated then [] else [MenuEntry]
entries [MenuEntry] -> [MenuEntry] -> [MenuEntry]
forall a. [a] -> [a] -> [a]
++ [[MenuEntry]] -> [MenuEntry]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[MenuEntry]]
subaes
  let fm :: Menu
fm = Menu {fmName :: String
fmName            = String -> (DesktopEntry -> String) -> Maybe DesktopEntry -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (XDGMenu -> String
xmName XDGMenu
xm) ([String] -> DesktopEntry -> String
deName [String]
langs) Maybe DesktopEntry
dirEntry,
                 fmComment :: String
fmComment         = String -> (DesktopEntry -> String) -> Maybe DesktopEntry -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"???" (String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"???" (Maybe String -> String)
-> (DesktopEntry -> Maybe String) -> DesktopEntry -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> DesktopEntry -> Maybe String
deComment [String]
langs) Maybe DesktopEntry
dirEntry,
                 fmIcon :: Maybe String
fmIcon            = DesktopEntry -> Maybe String
deIcon (DesktopEntry -> Maybe String)
-> Maybe DesktopEntry -> Maybe String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe DesktopEntry
dirEntry,
                 fmSubmenus :: [Menu]
fmSubmenus        = [Menu]
menus',
                 fmEntries :: [MenuEntry]
fmEntries         = [MenuEntry]
entries,
                 fmOnlyUnallocated :: Bool
fmOnlyUnallocated = Bool
onlyUnallocated}
  (Menu, [MenuEntry]) -> IO (Menu, [MenuEntry])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Menu
fm, [MenuEntry]
aes)

-- | Check the "only show in" logic
matchesOnlyShowIn :: String -> DesktopEntry -> Bool
matchesOnlyShowIn :: String -> DesktopEntry -> Bool
matchesOnlyShowIn String
desktop DesktopEntry
de = Bool
matchesShowIn Bool -> Bool -> Bool
&& Bool
notMatchesNotShowIn
  where matchesShowIn :: Bool
matchesShowIn = case DesktopEntry -> [String]
deOnlyShowIn DesktopEntry
de of
                          [] -> Bool
True
                          [String]
desktops -> String
desktop String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
desktops
        notMatchesNotShowIn :: Bool
notMatchesNotShowIn = case DesktopEntry -> [String]
deNotShowIn DesktopEntry
de of
                                [] -> Bool
True
                                [String]
desktops -> String
desktop String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [String]
desktops

-- | convert xdg desktop entry to displayble menu entry
xdgToMenuEntry :: [String] -> DesktopEntry -> MenuEntry
xdgToMenuEntry :: [String] -> DesktopEntry -> MenuEntry
xdgToMenuEntry [String]
langs DesktopEntry
de =
  MenuEntry
  {feName :: Text
feName = Text
name, feComment :: Text
feComment = Text
comment, feCommand :: String
feCommand = String
cmd, feIcon :: Maybe Text
feIcon = Maybe Text
mIcon}
  where
    mc :: Maybe String
mc =
      case DesktopEntry -> Maybe String
deCommand DesktopEntry
de of
        Maybe String
Nothing -> Maybe String
forall a. Maybe a
Nothing
        Just String
c -> String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String
"(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
c String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
    comment :: Text
comment =
      String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$
      String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"??" (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$
      case [String] -> DesktopEntry -> Maybe String
deComment [String]
langs DesktopEntry
de of
        Maybe String
Nothing -> Maybe String
mc
        Just String
tt -> String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String
tt String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> ShowS -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (String
"\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++) Maybe String
mc
    cmd :: String
cmd = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"FIXME" (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ DesktopEntry -> Maybe String
deCommand DesktopEntry
de
    name :: Text
name = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ [String] -> DesktopEntry -> String
deName [String]
langs DesktopEntry
de
    mIcon :: Maybe Text
mIcon = String -> Text
T.pack (String -> Text) -> Maybe String -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DesktopEntry -> Maybe String
deIcon DesktopEntry
de

-- | postprocess unallocated entries
fixOnlyUnallocated :: [MenuEntry] -> Menu -> Menu
fixOnlyUnallocated :: [MenuEntry] -> Menu -> Menu
fixOnlyUnallocated [MenuEntry]
fes Menu
fm =
  Menu
fm
  { fmEntries :: [MenuEntry]
fmEntries = [MenuEntry]
entries
  , fmSubmenus :: [Menu]
fmSubmenus = (Menu -> Menu) -> [Menu] -> [Menu]
forall a b. (a -> b) -> [a] -> [b]
map ([MenuEntry] -> Menu -> Menu
fixOnlyUnallocated [MenuEntry]
fes) (Menu -> [Menu]
fmSubmenus Menu
fm)
  }
  where
    entries :: [MenuEntry]
entries =
      if Menu -> Bool
fmOnlyUnallocated Menu
fm
        then (MenuEntry -> Bool) -> [MenuEntry] -> [MenuEntry]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (MenuEntry -> Bool) -> MenuEntry -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MenuEntry -> [MenuEntry] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [MenuEntry]
fes)) (Menu -> [MenuEntry]
fmEntries Menu
fm)
        else Menu -> [MenuEntry]
fmEntries Menu
fm