-----------------------------------------------------------------------------
-- |
-- Module      : System.Taffybar.Information.XDG.Protocol
-- 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 XDG "Desktop Menu
-- Specification", see
-- https://specifications.freedesktop.org/menu-spec/menu-spec-1.1.html
---- specification, see
-- See also 'MenuWidget'.
--
-----------------------------------------------------------------------------
module System.Taffybar.Information.XDG.Protocol
  ( XDGMenu(..)
  , DesktopEntryCondition(..)
  , getApplicationEntries
  , getDirectoryDirs
  , getPreferredLanguages
  , getXDGDesktop
  , getXDGMenuFilenames
  , matchesCondition
  , readXDGMenu
  ) where

import           Control.Applicative
import           Control.Monad
import           Control.Monad.Trans.Class
import           Control.Monad.Trans.Maybe
import           Data.Char (toLower)
import           Data.List
import           Data.Maybe
import qualified Debug.Trace as D
import           GHC.IO.Encoding
import           Safe (headMay)
import           System.Directory
import           System.Environment
import           System.Environment.XDG.DesktopEntry
import           System.FilePath.Posix
import           System.Log.Logger
import           System.Posix.Files
import           System.Taffybar.Util
import           Text.XML.Light
import           Text.XML.Light.Helpers

getXDGMenuPrefix :: IO (Maybe String)
getXDGMenuPrefix :: IO (Maybe String)
getXDGMenuPrefix = String -> IO (Maybe String)
lookupEnv String
"XDG_MENU_PREFIX"

-- | Find filename(s) of the application menu(s).
getXDGMenuFilenames
  :: Maybe String -- ^ Overrides the value of the environment variable
                  -- XDG_MENU_PREFIX. Specifies the prefix for the menu (e.g.
                  -- 'Just "mate-"').
  -> IO [FilePath]
getXDGMenuFilenames :: Maybe String -> IO [String]
getXDGMenuFilenames Maybe String
mMenuPrefix = do
  configDirs <-
    (String -> [String] -> [String])
-> IO String -> IO [String] -> IO [String]
forall a b c. (a -> b -> c) -> IO a -> IO b -> IO c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (:) (XdgDirectory -> String -> IO String
getXdgDirectory XdgDirectory
XdgConfig String
"")
             (XdgDirectoryList -> IO [String]
getXdgDirectoryList XdgDirectoryList
XdgConfigDirs)
  maybePrefix <- (mMenuPrefix <|>) <$> getXDGMenuPrefix
  let maybeAddDash String
t = if String -> Char
forall a. HasCallStack => [a] -> a
last String
t Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-' then String
t else String
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"-"
      dashedPrefix = String -> (String -> String) -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" String -> String
maybeAddDash Maybe String
maybePrefix
  return $ map (</> "menus" </> dashedPrefix ++ "applications.menu") configDirs

-- | XDG Menu, cf. "Desktop Menu Specification".
data XDGMenu = XDGMenu
  { XDGMenu -> Maybe String
xmAppDir :: Maybe String
  , XDGMenu -> Bool
xmDefaultAppDirs :: Bool -- Use $XDG_DATA_DIRS/applications
  , XDGMenu -> Maybe String
xmDirectoryDir :: Maybe String
  , XDGMenu -> Bool
xmDefaultDirectoryDirs :: Bool -- Use $XDG_DATA_DIRS/desktop-directories
  , XDGMenu -> [String]
xmLegacyDirs :: [String]
  , XDGMenu -> String
xmName :: String
  , XDGMenu -> String
xmDirectory :: String
  , XDGMenu -> Bool
xmOnlyUnallocated :: Bool
  , XDGMenu -> Bool
xmDeleted :: Bool
  , XDGMenu -> Maybe DesktopEntryCondition
xmInclude :: Maybe DesktopEntryCondition
  , XDGMenu -> Maybe DesktopEntryCondition
xmExclude :: Maybe DesktopEntryCondition
  , XDGMenu -> [XDGMenu]
xmSubmenus :: [XDGMenu]
  , XDGMenu -> [XDGLayoutItem]
xmLayout :: [XDGLayoutItem]
  } deriving (Int -> XDGMenu -> String -> String
[XDGMenu] -> String -> String
XDGMenu -> String
(Int -> XDGMenu -> String -> String)
-> (XDGMenu -> String)
-> ([XDGMenu] -> String -> String)
-> Show XDGMenu
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> XDGMenu -> String -> String
showsPrec :: Int -> XDGMenu -> String -> String
$cshow :: XDGMenu -> String
show :: XDGMenu -> String
$cshowList :: [XDGMenu] -> String -> String
showList :: [XDGMenu] -> String -> String
Show)

data XDGLayoutItem =
  XliFile String | XliSeparator | XliMenu String | XliMerge String
  deriving(Int -> XDGLayoutItem -> String -> String
[XDGLayoutItem] -> String -> String
XDGLayoutItem -> String
(Int -> XDGLayoutItem -> String -> String)
-> (XDGLayoutItem -> String)
-> ([XDGLayoutItem] -> String -> String)
-> Show XDGLayoutItem
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> XDGLayoutItem -> String -> String
showsPrec :: Int -> XDGLayoutItem -> String -> String
$cshow :: XDGLayoutItem -> String
show :: XDGLayoutItem -> String
$cshowList :: [XDGLayoutItem] -> String -> String
showList :: [XDGLayoutItem] -> String -> String
Show)

-- | Return a list of all available desktop entries for a given xdg menu.
getApplicationEntries
  :: [String] -- ^ Preferred languages
  -> XDGMenu
  -> IO [DesktopEntry]
getApplicationEntries :: [String] -> XDGMenu -> IO [DesktopEntry]
getApplicationEntries [String]
langs XDGMenu
xm = do
  defEntries <- if XDGMenu -> Bool
xmDefaultAppDirs XDGMenu
xm
    then do dataDirs <- IO [String]
getXDGDataDirs
            concat <$> mapM (listDesktopEntries ".desktop" .
                                                  (</> "applications")) dataDirs
    else [DesktopEntry] -> IO [DesktopEntry]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
  return $ sortBy (\DesktopEntry
de1 DesktopEntry
de2 -> String -> String -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ((Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower ([String] -> DesktopEntry -> String
deName [String]
langs DesktopEntry
de1))
                               ((Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower ([String] -> DesktopEntry -> String
deName [String]
langs DesktopEntry
de2))) defEntries

-- | Parse menu.
parseMenu :: Element -> Maybe XDGMenu
parseMenu :: Element -> Maybe XDGMenu
parseMenu Element
elt =
  let appDir :: Maybe String
appDir = String -> Element -> Maybe String
getChildData String
"AppDir" Element
elt
      defaultAppDirs :: Bool
defaultAppDirs = Maybe String -> Bool
forall a. Maybe a -> Bool
isJust (Maybe String -> Bool) -> Maybe String -> Bool
forall a b. (a -> b) -> a -> b
$ String -> Element -> Maybe String
getChildData String
"DefaultAppDirs" Element
elt
      directoryDir :: Maybe String
directoryDir = String -> Element -> Maybe String
getChildData String
"DirectoryDir" Element
elt
      defaultDirectoryDirs :: Bool
defaultDirectoryDirs = Maybe String -> Bool
forall a. Maybe a -> Bool
isJust (Maybe String -> Bool) -> Maybe String -> Bool
forall a b. (a -> b) -> a -> b
$ String -> Element -> Maybe String
getChildData String
"DefaultDirectoryDirs" Element
elt
      name :: String
name = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"Name?" (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ String -> Element -> Maybe String
getChildData String
"Name" Element
elt
      dir :: String
dir = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"Dir?" (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ String -> Element -> Maybe String
getChildData String
"Directory" Element
elt
      onlyUnallocated :: Bool
onlyUnallocated =
        case ( String -> Element -> Maybe String
getChildData String
"OnlyUnallocated" Element
elt
             , String -> Element -> Maybe String
getChildData String
"NotOnlyUnallocated" Element
elt) of
          (Maybe String
Nothing, Maybe String
Nothing) -> Bool
False -- ?!
          (Maybe String
Nothing, Just String
_) -> Bool
False
          (Just String
_, Maybe String
Nothing) -> Bool
True
          (Just String
_, Just String
_) -> Bool
False -- ?!
      deleted :: Bool
deleted = Bool
False -- FIXME
      include :: Maybe DesktopEntryCondition
include = String -> Element -> Maybe DesktopEntryCondition
parseConditions String
"Include" Element
elt
      exclude :: Maybe DesktopEntryCondition
exclude = String -> Element -> Maybe DesktopEntryCondition
parseConditions String
"Exclude" Element
elt
      layout :: [XDGLayoutItem]
layout = Element -> [XDGLayoutItem]
parseLayout Element
elt
      subMenus :: [XDGMenu]
subMenus = [XDGMenu] -> Maybe [XDGMenu] -> [XDGMenu]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [XDGMenu] -> [XDGMenu]) -> Maybe [XDGMenu] -> [XDGMenu]
forall a b. (a -> b) -> a -> b
$ String -> Element -> (Element -> Maybe XDGMenu) -> Maybe [XDGMenu]
forall a. String -> Element -> (Element -> Maybe a) -> Maybe [a]
mapChildren String
"Menu" Element
elt Element -> Maybe XDGMenu
parseMenu
  in XDGMenu -> Maybe XDGMenu
forall a. a -> Maybe a
Just
       XDGMenu
       { xmAppDir :: Maybe String
xmAppDir = Maybe String
appDir
       , xmDefaultAppDirs :: Bool
xmDefaultAppDirs = Bool
defaultAppDirs
       , xmDirectoryDir :: Maybe String
xmDirectoryDir = Maybe String
directoryDir
       , xmDefaultDirectoryDirs :: Bool
xmDefaultDirectoryDirs = Bool
defaultDirectoryDirs
       , xmLegacyDirs :: [String]
xmLegacyDirs = []
       , xmName :: String
xmName = String
name
       , xmDirectory :: String
xmDirectory = String
dir
       , xmOnlyUnallocated :: Bool
xmOnlyUnallocated = Bool
onlyUnallocated
       , xmDeleted :: Bool
xmDeleted = Bool
deleted
       , xmInclude :: Maybe DesktopEntryCondition
xmInclude = Maybe DesktopEntryCondition
include
       , xmExclude :: Maybe DesktopEntryCondition
xmExclude = Maybe DesktopEntryCondition
exclude
       , xmSubmenus :: [XDGMenu]
xmSubmenus = [XDGMenu]
subMenus
       , xmLayout :: [XDGLayoutItem]
xmLayout = [XDGLayoutItem]
layout -- FIXME
       }

-- | Parse Desktop Entry conditions for Include/Exclude clauses.
parseConditions :: String -> Element -> Maybe DesktopEntryCondition
parseConditions :: String -> Element -> Maybe DesktopEntryCondition
parseConditions String
key Element
elt = case QName -> Element -> Maybe Element
findChild (String -> QName
unqual String
key) Element
elt of
  Maybe Element
Nothing -> Maybe DesktopEntryCondition
forall a. Maybe a
Nothing
  Just Element
inc -> [Element] -> Maybe DesktopEntryCondition
doParseConditions (Element -> [Element]
elChildren Element
inc)
  where doParseConditions :: [Element] -> Maybe DesktopEntryCondition
        doParseConditions :: [Element] -> Maybe DesktopEntryCondition
doParseConditions []   = Maybe DesktopEntryCondition
forall a. Maybe a
Nothing
        doParseConditions [Element
e]  = Element -> Maybe DesktopEntryCondition
parseSingleItem Element
e
        doParseConditions [Element]
elts = DesktopEntryCondition -> Maybe DesktopEntryCondition
forall a. a -> Maybe a
Just (DesktopEntryCondition -> Maybe DesktopEntryCondition)
-> DesktopEntryCondition -> Maybe DesktopEntryCondition
forall a b. (a -> b) -> a -> b
$ [DesktopEntryCondition] -> DesktopEntryCondition
Or ([DesktopEntryCondition] -> DesktopEntryCondition)
-> [DesktopEntryCondition] -> DesktopEntryCondition
forall a b. (a -> b) -> a -> b
$ (Element -> Maybe DesktopEntryCondition)
-> [Element] -> [DesktopEntryCondition]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Element -> Maybe DesktopEntryCondition
parseSingleItem [Element]
elts

        parseSingleItem :: Element -> Maybe DesktopEntryCondition
parseSingleItem Element
e = case QName -> String
qName (Element -> QName
elName Element
e) of
          String
"Category" -> DesktopEntryCondition -> Maybe DesktopEntryCondition
forall a. a -> Maybe a
Just (DesktopEntryCondition -> Maybe DesktopEntryCondition)
-> DesktopEntryCondition -> Maybe DesktopEntryCondition
forall a b. (a -> b) -> a -> b
$ String -> DesktopEntryCondition
Category (String -> DesktopEntryCondition)
-> String -> DesktopEntryCondition
forall a b. (a -> b) -> a -> b
$ Element -> String
strContent Element
e
          String
"Filename" -> DesktopEntryCondition -> Maybe DesktopEntryCondition
forall a. a -> Maybe a
Just (DesktopEntryCondition -> Maybe DesktopEntryCondition)
-> DesktopEntryCondition -> Maybe DesktopEntryCondition
forall a b. (a -> b) -> a -> b
$ String -> DesktopEntryCondition
Filename (String -> DesktopEntryCondition)
-> String -> DesktopEntryCondition
forall a b. (a -> b) -> a -> b
$ Element -> String
strContent Element
e
          String
"And"      -> DesktopEntryCondition -> Maybe DesktopEntryCondition
forall a. a -> Maybe a
Just (DesktopEntryCondition -> Maybe DesktopEntryCondition)
-> DesktopEntryCondition -> Maybe DesktopEntryCondition
forall a b. (a -> b) -> a -> b
$ [DesktopEntryCondition] -> DesktopEntryCondition
And ([DesktopEntryCondition] -> DesktopEntryCondition)
-> [DesktopEntryCondition] -> DesktopEntryCondition
forall a b. (a -> b) -> a -> b
$ (Element -> Maybe DesktopEntryCondition)
-> [Element] -> [DesktopEntryCondition]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Element -> Maybe DesktopEntryCondition
parseSingleItem
                          ([Element] -> [DesktopEntryCondition])
-> [Element] -> [DesktopEntryCondition]
forall a b. (a -> b) -> a -> b
$ Element -> [Element]
elChildren Element
e
          String
"Or"       -> DesktopEntryCondition -> Maybe DesktopEntryCondition
forall a. a -> Maybe a
Just (DesktopEntryCondition -> Maybe DesktopEntryCondition)
-> DesktopEntryCondition -> Maybe DesktopEntryCondition
forall a b. (a -> b) -> a -> b
$ [DesktopEntryCondition] -> DesktopEntryCondition
Or  ([DesktopEntryCondition] -> DesktopEntryCondition)
-> [DesktopEntryCondition] -> DesktopEntryCondition
forall a b. (a -> b) -> a -> b
$ (Element -> Maybe DesktopEntryCondition)
-> [Element] -> [DesktopEntryCondition]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Element -> Maybe DesktopEntryCondition
parseSingleItem
                          ([Element] -> [DesktopEntryCondition])
-> [Element] -> [DesktopEntryCondition]
forall a b. (a -> b) -> a -> b
$ Element -> [Element]
elChildren Element
e
          String
"Not"      -> DesktopEntryCondition -> DesktopEntryCondition
Not (DesktopEntryCondition -> DesktopEntryCondition)
-> Maybe DesktopEntryCondition -> Maybe DesktopEntryCondition
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Element -> Maybe DesktopEntryCondition
parseSingleItem (Element -> Maybe DesktopEntryCondition)
-> Maybe Element -> Maybe DesktopEntryCondition
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Element] -> Maybe Element
forall a. [a] -> Maybe a
listToMaybe (Element -> [Element]
elChildren Element
e))
          String
unknown    -> String
-> Maybe DesktopEntryCondition -> Maybe DesktopEntryCondition
forall a. String -> a -> a
D.trace (String
"Unknown Condition item: " String -> String -> String
forall a. [a] -> [a] -> [a]
++  String
unknown) Maybe DesktopEntryCondition
forall a. Maybe a
Nothing

-- | Combinable conditions for Include and Exclude statements.
data DesktopEntryCondition = Category String
                           | Filename String
                           | Not DesktopEntryCondition
                           | And [DesktopEntryCondition]
                           | Or [DesktopEntryCondition]
                           | All
                           | None
  deriving (ReadPrec [DesktopEntryCondition]
ReadPrec DesktopEntryCondition
Int -> ReadS DesktopEntryCondition
ReadS [DesktopEntryCondition]
(Int -> ReadS DesktopEntryCondition)
-> ReadS [DesktopEntryCondition]
-> ReadPrec DesktopEntryCondition
-> ReadPrec [DesktopEntryCondition]
-> Read DesktopEntryCondition
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS DesktopEntryCondition
readsPrec :: Int -> ReadS DesktopEntryCondition
$creadList :: ReadS [DesktopEntryCondition]
readList :: ReadS [DesktopEntryCondition]
$creadPrec :: ReadPrec DesktopEntryCondition
readPrec :: ReadPrec DesktopEntryCondition
$creadListPrec :: ReadPrec [DesktopEntryCondition]
readListPrec :: ReadPrec [DesktopEntryCondition]
Read, Int -> DesktopEntryCondition -> String -> String
[DesktopEntryCondition] -> String -> String
DesktopEntryCondition -> String
(Int -> DesktopEntryCondition -> String -> String)
-> (DesktopEntryCondition -> String)
-> ([DesktopEntryCondition] -> String -> String)
-> Show DesktopEntryCondition
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> DesktopEntryCondition -> String -> String
showsPrec :: Int -> DesktopEntryCondition -> String -> String
$cshow :: DesktopEntryCondition -> String
show :: DesktopEntryCondition -> String
$cshowList :: [DesktopEntryCondition] -> String -> String
showList :: [DesktopEntryCondition] -> String -> String
Show, DesktopEntryCondition -> DesktopEntryCondition -> Bool
(DesktopEntryCondition -> DesktopEntryCondition -> Bool)
-> (DesktopEntryCondition -> DesktopEntryCondition -> Bool)
-> Eq DesktopEntryCondition
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DesktopEntryCondition -> DesktopEntryCondition -> Bool
== :: DesktopEntryCondition -> DesktopEntryCondition -> Bool
$c/= :: DesktopEntryCondition -> DesktopEntryCondition -> Bool
/= :: DesktopEntryCondition -> DesktopEntryCondition -> Bool
Eq)

parseLayout :: Element -> [XDGLayoutItem]
parseLayout :: Element -> [XDGLayoutItem]
parseLayout Element
elt = case QName -> Element -> Maybe Element
findChild (String -> QName
unqual String
"Layout") Element
elt of
  Maybe Element
Nothing -> []
  Just Element
lt -> (Element -> Maybe XDGLayoutItem) -> [Element] -> [XDGLayoutItem]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Element -> Maybe XDGLayoutItem
parseLayoutItem (Element -> [Element]
elChildren Element
lt)
  where parseLayoutItem :: Element -> Maybe XDGLayoutItem
        parseLayoutItem :: Element -> Maybe XDGLayoutItem
parseLayoutItem Element
e = case QName -> String
qName (Element -> QName
elName Element
e) of
          String
"Separator" -> XDGLayoutItem -> Maybe XDGLayoutItem
forall a. a -> Maybe a
Just XDGLayoutItem
XliSeparator
          String
"Filename"  -> XDGLayoutItem -> Maybe XDGLayoutItem
forall a. a -> Maybe a
Just (XDGLayoutItem -> Maybe XDGLayoutItem)
-> XDGLayoutItem -> Maybe XDGLayoutItem
forall a b. (a -> b) -> a -> b
$ String -> XDGLayoutItem
XliFile (String -> XDGLayoutItem) -> String -> XDGLayoutItem
forall a b. (a -> b) -> a -> b
$ Element -> String
strContent Element
e
          String
unknown     -> String -> Maybe XDGLayoutItem -> Maybe XDGLayoutItem
forall a. String -> a -> a
D.trace (String
"Unknown layout item: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
unknown) Maybe XDGLayoutItem
forall a. Maybe a
Nothing

-- | Determine whether a desktop entry fulfils a condition.
matchesCondition :: DesktopEntry -> DesktopEntryCondition -> Bool
matchesCondition :: DesktopEntry -> DesktopEntryCondition -> Bool
matchesCondition DesktopEntry
de (Category String
cat) = DesktopEntry -> String -> Bool
deHasCategory DesktopEntry
de String
cat
matchesCondition DesktopEntry
de (Filename String
fn)  = String
fn String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== DesktopEntry -> String
deFilename DesktopEntry
de
matchesCondition DesktopEntry
de (Not DesktopEntryCondition
cond)     = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ DesktopEntry -> DesktopEntryCondition -> Bool
matchesCondition DesktopEntry
de DesktopEntryCondition
cond
matchesCondition DesktopEntry
de (And [DesktopEntryCondition]
conds)    = (DesktopEntryCondition -> Bool) -> [DesktopEntryCondition] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (DesktopEntry -> DesktopEntryCondition -> Bool
matchesCondition DesktopEntry
de) [DesktopEntryCondition]
conds
matchesCondition DesktopEntry
de (Or [DesktopEntryCondition]
conds)     = (DesktopEntryCondition -> Bool) -> [DesktopEntryCondition] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (DesktopEntry -> DesktopEntryCondition -> Bool
matchesCondition DesktopEntry
de) [DesktopEntryCondition]
conds
matchesCondition DesktopEntry
_  DesktopEntryCondition
All            = Bool
True
matchesCondition DesktopEntry
_  DesktopEntryCondition
None           = Bool
False

-- | Determine locale language settings
getPreferredLanguages :: IO [String]
getPreferredLanguages :: IO [String]
getPreferredLanguages = do
  mLcMessages <- String -> IO (Maybe String)
lookupEnv String
"LC_MESSAGES"
  lang <- case mLcMessages of
               Maybe String
Nothing -> String -> IO (Maybe String)
lookupEnv String
"LANG" -- FIXME?
               Just String
lm -> Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Maybe String
forall a. a -> Maybe a
Just String
lm)
  case lang of
    Maybe String
Nothing -> [String] -> IO [String]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
    Just String
l -> [String] -> IO [String]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> IO [String]) -> [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$
      let woEncoding :: String
woEncoding      = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'.') String
l
          (String
language, String
_cm) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'_') String
woEncoding
          (String
country, String
_m)   = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'@') (Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
1 String
_cm)
          modifier :: String
modifier        = Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
1 String
_m
                       in String -> String -> String -> [String]
dgl String
language String
country String
modifier
    where dgl :: String -> String -> String -> [String]
dgl String
"" String
"" String
"" = []
          dgl String
l  String
"" String
"" = [String
l]
          dgl String
l  String
c  String
"" = [String
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
c, String
l]
          dgl String
l  String
"" String
m  = [String
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"@" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
m, String
l]
          dgl String
l  String
c  String
m  = [String
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"@" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
m, String
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
c,
                          String
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"@" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
m]

-- | Determine current Desktop
getXDGDesktop :: IO String
getXDGDesktop :: IO String
getXDGDesktop = do
  mCurDt <- String -> IO (Maybe String)
lookupEnv String
"XDG_CURRENT_DESKTOP"
  return $ fromMaybe "???" mCurDt

-- | Return desktop directories
getDirectoryDirs :: IO [FilePath]
getDirectoryDirs :: IO [String]
getDirectoryDirs = do
  dataDirs <- IO [String]
getXDGDataDirs
  filterM (fileExist . (</> "desktop-directories")) dataDirs

-- | Fetch menus and desktop entries and assemble the XDG menu.
readXDGMenu :: Maybe String -> IO (Maybe (XDGMenu, [DesktopEntry]))
readXDGMenu :: Maybe String -> IO (Maybe (XDGMenu, [DesktopEntry]))
readXDGMenu Maybe String
mMenuPrefix = do
  TextEncoding -> IO ()
setLocaleEncoding TextEncoding
utf8
  filenames <- Maybe String -> IO [String]
getXDGMenuFilenames Maybe String
mMenuPrefix
  headMay . catMaybes <$> traverse maybeMenu filenames

-- | Load and assemble the XDG menu from a specific file, if it exists.
maybeMenu :: FilePath -> IO (Maybe (XDGMenu, [DesktopEntry]))
maybeMenu :: String -> IO (Maybe (XDGMenu, [DesktopEntry]))
maybeMenu String
filename =
  IO Bool
-> IO (Maybe (XDGMenu, [DesktopEntry]))
-> IO (Maybe (XDGMenu, [DesktopEntry]))
-> IO (Maybe (XDGMenu, [DesktopEntry]))
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (String -> IO Bool
doesFileExist String
filename)
      (do
        contents <- String -> IO String
readFile String
filename
        langs <- getPreferredLanguages
        runMaybeT $ do
          m <- MaybeT $ return $ parseXMLDoc contents >>= parseMenu
          des <- lift $ getApplicationEntries langs m
          return (m, des))
       (do
         String -> Priority -> String -> IO ()
logM String
"System.Taffybar.Information.XDG.Protocol" Priority
WARNING (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
                String
"Menu file '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
filename String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' does not exist!"
         Maybe (XDGMenu, [DesktopEntry])
-> IO (Maybe (XDGMenu, [DesktopEntry]))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (XDGMenu, [DesktopEntry])
forall a. Maybe a
Nothing)