add .desktop prompt launcher

XMonad/Prompt/DotDesktop.hs

@@ -0,0 +1,77 @@
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE LambdaCase #-}
+module XMonad.Prompt.DotDesktop
+    ( appLaunchPrompt
+    ) where
+
+import XMonad ( spawn, io, X )
+import XMonad.Prompt ( mkXPrompt, XPConfig(searchPredicate) )
+import XMonad.Prompt.Shell ( Shell(Shell) )
+import XMonad.Prompt.DotDesktopParser ( doParseContent
+                                      , DotDesktopApp (..) )
+
+import qualified Data.Map as M
+import Control.Monad ( filterM )
+import Control.Exception ( try, Exception )
+import Data.Functor ( (<&>) )
+import Data.List ( isSuffixOf )
+import System.Directory ( listDirectory
+                        , doesDirectoryExist
+                        , getXdgDirectory
+                        , XdgDirectory (XdgData)
+                        , XdgDirectoryList (XdgDataDirs)
+                        , getXdgDirectoryList)
+import System.FilePath ( (</>) )
+
+import Data.Either ( rights, lefts )
+import XMonad.Prelude ( join )
+
+isDotDesktop :: FilePath -> Bool
+isDotDesktop = isSuffixOf ".desktop"
+
+exceptionToString :: Exception e => Either e a -> Either String a
+exceptionToString = either (Left . show) Right
+
+doReadFileLBS :: String -> IO (Either String String)
+doReadFileLBS = fmap exceptionToString . try @IOError . readFile
+
+doParseFile :: String -> IO (Either String DotDesktopApp)
+doParseFile filePath = doReadFileLBS filePath
+                   <&> (>>= doParseContent filePath)
+
+getAppFolders :: IO [FilePath]
+getAppFolders = do
+  xdgDataHome <- getXdgDirectory XdgData ""
+  xdgDataDirs <- getXdgDirectoryList XdgDataDirs
+  let possibleAppDirs = (xdgDataHome : xdgDataDirs) <&> (</> "applications")
+  filterM doesDirectoryExist possibleAppDirs
+
+getDirContents :: FilePath -> IO (Either String [FilePath])
+getDirContents dir = do
+  fn <- fmap exceptionToString . try @IOError . listDirectory $ dir
+  return $ (fmap . fmap) (dir </>) fn
+
+getDotDesktopApps :: IO [DotDesktopApp]
+getDotDesktopApps = do
+  appFolders <- getAppFolders
+  contentsPerFolder <- mapM getDirContents appFolders
+  let folderFiles = join $ rights contentsPerFolder
+      dotDesktopFiles = filter isDotDesktop folderFiles
+      folderWarnings = join $ lefts contentsPerFolder
+  mapM_ print folderWarnings
+  parseResults <- mapM doParseFile dotDesktopFiles
+  let parseErrs = lefts parseResults
+      dotDesktopApps = rights parseResults
+  mapM_ print parseErrs
+  return dotDesktopApps
+
+appLaunchPrompt :: XPConfig -> X ()
+appLaunchPrompt cfg = do
+    cmdNameMap <- io $ getDotDesktopApps <&> map (\el -> (name el, cmd el)) <&> M.fromList
+    let cmdNameMapKeys = M.keys cmdNameMap
+        complFunc :: String -> [String]
+        complFunc s = filter (searchPredicate cfg s) cmdNameMapKeys
+        --
+        complAction :: String -> X ()
+        complAction s = spawn $ cmdNameMap M.! s
+    mkXPrompt Shell cfg (pure . complFunc) complAction

XMonad/Prompt/DotDesktopParser.hs

@@ -0,0 +1,144 @@
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE LambdaCase #-}
+module XMonad.Prompt.DotDesktopParser
+    ( doParseContent
+    , DotDesktopApp (..)
+    ) where
+
+import Text.ParserCombinators.ReadP
+    ( ReadP
+    , (<++)
+    , char
+    , eof
+    , many
+    , many1
+    , readP_to_S
+    , satisfy
+    , skipSpaces
+    , string
+    , between
+    ,  (+++) )
+import Data.Maybe ( listToMaybe, catMaybes, fromMaybe )
+import qualified Data.Map as MAP
+import Control.Monad ( (>=>), void )
+import Data.Char ( isSpace )
+import Data.List ( dropWhileEnd )
+
+type Predicate a = a -> Bool
+
+notP :: Predicate a -> Predicate a
+notP = (not .)
+
+notOneOf :: String -> ReadP Char
+notOneOf s = satisfy (notP (`elem` s))
+
+newline :: ReadP ()
+newline = void (char '\n')
+
+squareBrackets :: ReadP a -> ReadP a
+squareBrackets = between (char '[') (char ']')
+
+keyName :: ReadP String
+keyName = many1 (notOneOf "=\n \t")
+
+keyValue :: ReadP (String, String)
+keyValue = do
+  key <- keyName
+  skipSpaces
+  char '='
+  skipSpaces
+  val <- many (notOneOf "\n")
+  char '\n'
+  return (key, val)
+
+desktopEntrySectionLine :: ReadP (Either String String)
+desktopEntrySectionLine = do
+  sectionName <- squareBrackets (string "Desktop Entry")
+  newline
+  return $ Right sectionName
+
+badSectionLine :: ReadP (Either String String)
+badSectionLine = do
+  startChar <- char '['
+  otherChar <- many $ notOneOf "\n"
+  newline
+  return $ Left $ startChar : otherChar
+
+emptyLine :: ReadP ()
+emptyLine = do
+  whitespaceLine +++ commentLine +++ newline
+  return ()
+  where whitespaceLine = skipSpaces >> newline
+        commentLine = skipSpaces
+                   >> char '#'
+                   >> many (notOneOf "\n")
+                   >> newline
+
+sectionBodyLine :: ReadP (Maybe (String, String))
+sectionBodyLine = (Just <$> keyValue)
+                  <++ (Nothing <$ emptyLine)
+
+section :: ReadP (Either String (String, MAP.Map String String))
+section = do
+  many emptyLine
+  sec <- desktopEntrySectionLine <++ badSectionLine
+  keyValsList <- catMaybes <$> many sectionBodyLine
+  let keyVals = MAP.fromList keyValsList
+  return $ (,keyVals) <$> sec
+
+dotDesktopReadP :: ReadP [Either String (String, MAP.Map String String)]
+dotDesktopReadP = do
+  sections <- many section
+  eof
+  return sections
+
+runDotDesktopParser :: String -> Maybe (Either String (String, MAP.Map String String))
+runDotDesktopParser = (listToMaybe . readP_to_S dotDesktopReadP) >=> (listToMaybe . fst)
+
+maybeToEither :: b -> Maybe a -> Either b a
+maybeToEither _ (Just a) = Right a
+maybeToEither b Nothing = Left b
+
+getVal :: String -> String
+  -> MAP.Map String String -> Either String String
+getVal msg k kvmap = maybeToEither msg $ MAP.lookup k kvmap
+
+cmdFilter :: String -> String  -- fixme future do something other than dropping these
+cmdFilter ('%':'f':xs) = cmdFilter xs
+cmdFilter ('%':'F':xs) = cmdFilter xs
+cmdFilter ('%':'u':xs) = cmdFilter xs
+cmdFilter ('%':'U':xs) = cmdFilter xs
+cmdFilter ('%':'c':xs) = cmdFilter xs
+cmdFilter ('%':'k':xs) = cmdFilter xs
+cmdFilter ('%':'i':xs) = cmdFilter xs
+cmdFilter ('%':'%':xs) = '%' : cmdFilter xs
+cmdFilter (x:xs) = x : cmdFilter xs
+cmdFilter "" = ""
+
+trimWhitespace :: String -> String
+trimWhitespace = dropWhileEnd isSpace . dropWhile isSpace
+
+doParseContent :: String -> String -> Either String DotDesktopApp
+doParseContent filePath content = do
+  parsed <- fromMaybe
+            (Left $ "Parse Resulted in no KeyVals in file " ++ filePath)
+            (runDotDesktopParser content)
+  let keyVals = snd parsed
+  let errMsg = "Unable to find Name in file " ++ filePath
+  nom <- getVal errMsg "Name" keyVals
+  exc <- getVal errMsg "Exec" keyVals
+  typ <- getVal errMsg "Type" keyVals
+  return DotDesktopApp { fileName = filePath
+                       , name = nom
+                       , type_ = typ
+                       , exec = exc
+                       , cmd = (trimWhitespace . cmdFilter) exc
+                       }
+
+data DotDesktopApp = DotDesktopApp { fileName :: String
+                             , name :: String
+                             , type_ :: String
+                             , exec :: String
+                             , cmd :: String
+                             } deriving Show
+

xmonad-contrib.cabal

@@ -316,6 +316,8 @@ library
                         XMonad.Prompt.AppendFile
                         XMonad.Prompt.ConfirmPrompt
                         XMonad.Prompt.DirExec
+                        XMonad.Prompt.DotDesktop
+                        XMonad.Prompt.DotDesktopParser
                         XMonad.Prompt.Directory
                         XMonad.Prompt.Email
                         XMonad.Prompt.FuzzyMatch