    -----------------------------------------------------------------------------
    -- |
    -- 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
    /= :: Menu -> Menu -> Bool
    $c/= :: Menu -> Menu -> Bool
    == :: Menu -> Menu -> Bool
    $c== :: 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
    showList :: [Menu] -> ShowS
    $cshowList :: [Menu] -> ShowS
    show :: Menu -> String
    $cshow :: Menu -> String
    showsPrec :: Int -> Menu -> ShowS
    $cshowsPrec :: Int -> 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
    /= :: MenuEntry -> MenuEntry -> Bool
    $c/= :: MenuEntry -> MenuEntry -> Bool
    == :: MenuEntry -> MenuEntry -> Bool
    $c== :: 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
    showList :: [MenuEntry] -> ShowS
    $cshowList :: [MenuEntry] -> ShowS
    show :: MenuEntry -> String
    $cshow :: MenuEntry -> String
    showsPrec :: Int -> MenuEntry -> ShowS
    $cshowsPrec :: Int -> MenuEntry -> ShowS
    Show)

    -- | Fetch menus and desktop entries and assemble the menu.
    buildMenu :: Maybe String -> IO Menu
    buildMenu :: Maybe String -> IO Menu
    buildMenu mMenuPrefix :: Maybe String
    mMenuPrefix = do
      Maybe (XDGMenu, [DesktopEntry])
    mMenuDes <- Maybe String -> IO (Maybe (XDGMenu, [DesktopEntry]))
    readXDGMenu Maybe String
    mMenuPrefix
      case Maybe (XDGMenu, [DesktopEntry])
    mMenuDes of
        Nothing -> Menu -> IO Menu
    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 "???" "Parsing failed" Maybe String
    forall a. Maybe a
    Nothing [] [] Bool
    False
        Just (menu :: XDGMenu
    menu, des :: [DesktopEntry]
    des) -> do
          String
    dt <- IO String
    getXDGDesktop
          [String]
    dirDirs <- IO [String]
    getDirectoryDirs
          [String]
    langs <- IO [String]
    getPreferredLanguages
          (fm :: Menu
    fm, ae :: [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 (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 desktop :: String
    desktop langs :: [String]
    langs dirDirs :: [String]
    dirDirs des :: [DesktopEntry]
    des xm :: 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)
    mapM (String
    -> [String]
    -> [String]
    -> [DesktopEntry]
    -> XDGMenu
    -> IO (Menu, [MenuEntry])
    xdgToMenu String
    desktop [String]
    langs [String]
    dirDirs [DesktopEntry]
    des) (XDGMenu -> [XDGMenu]
    xmSubmenus XDGMenu
    xm)
      let (menus :: [Menu]
    menus, subaes :: [[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 (\fm1 :: Menu
    fm1 fm2 :: 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 :: String
    -> String -> Maybe String -> [Menu] -> [MenuEntry] -> Bool -> Menu
    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 -> Maybe String -> String
    forall a. a -> Maybe a -> a
    fromMaybe "???" (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 (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 desktop :: String
    desktop de :: DesktopEntry
    de = Bool
    matchesShowIn Bool -> Bool -> Bool
    && Bool
    notMatchesNotShowIn
      where matchesShowIn :: Bool
    matchesShowIn = case DesktopEntry -> [String]
    deOnlyShowIn DesktopEntry
    de of
                              [] -> Bool
    True
                              desktops :: [String]
    desktops -> String
    desktop String -> [String] -> 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
                                    desktops :: [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 langs :: [String]
    langs de :: DesktopEntry
    de =
      MenuEntry :: Text -> Text -> String -> Maybe Text -> MenuEntry
    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
            Nothing -> Maybe String
    forall a. Maybe a
    Nothing
            Just c :: 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 -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    c String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ ")"
        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 "??" (Maybe String -> String) -> Maybe String -> String
    forall a b. (a -> b) -> a -> b
    $
          case [String] -> DesktopEntry -> Maybe String
    deComment [String]
    langs DesktopEntry
    de of
            Nothing -> Maybe String
    mc
            Just tt :: 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 "" ("\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 "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 fes :: [MenuEntry]
    fes fm :: 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 (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` [MenuEntry]
    fes)) (Menu -> [MenuEntry]
    fmEntries Menu
    fm)
            else Menu -> [MenuEntry]
    fmEntries Menu
    fm