{-# OPTIONS_HADDOCK hide #-}
module System.Taffybar.Menu.Menu (
Menu(..),
MenuEntry(..),
buildMenu,
getApplicationEntries)
where
import Data.Char (toLower)
import Data.List
import Data.Maybe
import System.Taffybar.Menu.DesktopEntry
import System.Taffybar.Menu.XdgMenu
data Menu = Menu {
fmName :: String,
fmComment :: String,
fmIcon :: Maybe String,
fmSubmenus :: [Menu],
fmEntries :: [MenuEntry],
fmOnlyUnallocated :: Bool}
deriving (Show)
data MenuEntry = MenuEntry {
feName :: String,
feComment :: String,
feCommand :: String,
feIcon :: Maybe String}
deriving (Eq, Show)
buildMenu :: Maybe String -> IO Menu
buildMenu mMenuPrefix = do
mMenuDes <- readXdgMenu mMenuPrefix
case mMenuDes of
Nothing -> return $ Menu "???" "Parsing failed" Nothing [] [] False
Just (menu, des) -> do dt <- getXdgDesktop
dirDirs <- getDirectoryDirs
langs <- getPreferredLanguages
(fm, ae) <- xdgToMenu dt langs dirDirs des menu
let fm' = fixOnlyUnallocated ae fm
return fm'
xdgToMenu :: String -> [String] -> [FilePath] -> [DesktopEntry] -> XdgMenu
-> IO (Menu, [MenuEntry])
xdgToMenu desktop langs dirDirs des xm = do
dirEntry <- getDirectoryEntry (xmDirectory xm) dirDirs
mas <- mapM (xdgToMenu desktop langs dirDirs des) (xmSubmenus xm)
let (menus, subaes) = unzip mas
menus' = sortBy (\fm1 fm2 -> compare (map toLower $ fmName fm1)
(map toLower $ fmName fm2)) menus
entries = map (xdgToMenuEntry langs) $
filter (not . deNoDisplay) $
filter (matchesOnlyShowIn desktop) $
filter (not . flip matchesCondition (fromMaybe None (xmExclude xm))) $
filter (flip matchesCondition (fromMaybe None (xmInclude xm))) des
onlyUnallocated = xmOnlyUnallocated xm
aes = if onlyUnallocated then [] else entries ++ concat subaes
let fm = Menu {fmName = maybe (xmName xm) (deName langs) dirEntry,
fmComment = maybe "???" (fromMaybe "???" . deComment langs) dirEntry,
fmIcon = deIcon =<< dirEntry,
fmSubmenus = menus',
fmEntries = entries,
fmOnlyUnallocated = onlyUnallocated}
return (fm, aes)
matchesOnlyShowIn :: String -> DesktopEntry -> Bool
matchesOnlyShowIn desktop de = matchesShowIn && notMatchesNotShowIn
where matchesShowIn = case deOnlyShowIn de of
[] -> True
desktops -> desktop `elem` desktops
notMatchesNotShowIn = case deNotShowIn de of
[] -> True
desktops -> not $ desktop `elem` desktops
xdgToMenuEntry :: [String] -> DesktopEntry -> MenuEntry
xdgToMenuEntry langs de = MenuEntry {feName = name,
feComment = comment,
feCommand = cmd,
feIcon = mIcon}
where mc = case deCommand de of
Nothing -> Nothing
Just c -> Just $ "(" ++ c ++ ")"
comment = fromMaybe "??" $ case deComment langs de of
Nothing -> mc
Just tt -> Just $ tt ++ maybe "" ("\n" ++) mc
cmd = fromMaybe "FIXME" $ deCommand de
name = deName langs de
mIcon = deIcon de
fixOnlyUnallocated :: [MenuEntry] -> Menu -> Menu
fixOnlyUnallocated fes fm = fm {fmEntries = entries,
fmSubmenus = map (fixOnlyUnallocated fes) (fmSubmenus fm)}
where entries = if (fmOnlyUnallocated fm)
then filter (not . (`elem` fes)) (fmEntries fm)
else fmEntries fm