Menu.hs

-----------------------------------------------------------------------------
-- |
-- 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
  { fmName :: String
  , fmComment :: String
  , fmIcon :: Maybe String
  , fmSubmenus :: [Menu]
  , fmEntries :: [MenuEntry]
  , fmOnlyUnallocated :: Bool
  } deriving (Eq, Show)

-- | Displayable menu entry
data MenuEntry = MenuEntry
  { feName :: T.Text
  , feComment :: T.Text
  , feCommand :: String
  , feIcon :: Maybe T.Text
  } deriving (Eq, Show)

-- | Fetch menus and desktop entries and assemble the menu.
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'

-- | Convert xdg menu to displayable menu
xdgToMenu
  :: String
  -> [String]
  -> [FilePath]
  -> [DesktopEntry]
  -> XDGMenu
  -> IO (Menu, [MenuEntry])
xdgToMenu desktop langs dirDirs des xm = do
  dirEntry <- getDirectoryEntry dirDirs (xmDirectory xm)
  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) $
                -- hide NoDisplay
                filter (not . deNoDisplay) $
                -- onlyshowin
                filter (matchesOnlyShowIn desktop) $
                -- excludes
                filter (not . flip matchesCondition (fromMaybe None (xmExclude xm))) $
                -- includes
                filter (`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)

-- | Check the "only show in" logic
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 -> desktop `notElem` desktops

-- | convert xdg desktop entry to displayble menu entry
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 =
      T.pack $
      fromMaybe "??" $
      case deComment langs de of
        Nothing -> mc
        Just tt -> Just $ tt ++ maybe "" ("\n" ++) mc
    cmd = fromMaybe "FIXME" $ deCommand de
    name = T.pack $ deName langs de
    mIcon = T.pack <$> deIcon de

-- | postprocess unallocated entries
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