add .desktop prompt launcher

XMonad/Prompt/DotDesktop.hs

@@ -0,0 +1,129 @@
+{-# 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 ( runDotDesktopParser )
+
+import qualified Data.Map as M
+import Control.Monad (filterM)
+import Control.Monad.Except
+    ( runExceptT, ExceptT (ExceptT), liftEither )
+import Control.Exception ( try, Exception )
+import Data.Functor ( (<&>) )
+import Data.List ( isSuffixOf, dropWhileEnd )
+import Data.Maybe ( listToMaybe )
+import System.Directory (listDirectory, doesDirectoryExist, getXdgDirectory, XdgDirectory (XdgData), XdgDirectoryList (XdgDataDirs), getXdgDirectoryList)
+import System.FilePath ((</>))
+
+import Data.Char (isSpace)
+import Data.Either (rights, lefts)
+import XMonad.Prelude (join)
+
+isDotDesktop :: FilePath -> Bool
+isDotDesktop = isSuffixOf ".desktop"
+
+trimWhitespace :: String -> String
+trimWhitespace = dropWhileEnd isSpace . dropWhile isSpace
+
+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 "" = ""
+
+convertExceptionToString :: Exception e => IO (Either e a) -> IO (Either String a)
+convertExceptionToString = fmap convertExceptionToStringHelper
+
+convertExceptionToStringHelper :: Exception e => Either e a -> Either String a
+convertExceptionToStringHelper = either (Left . convertExceptionToStringHelperHelper) Right
+
+convertExceptionToStringHelperHelper :: Exception e => e -> String
+convertExceptionToStringHelperHelper = show :: Exception e => e -> String
+
+doReadFileLBS :: String -> ExceptT String IO String
+doReadFileLBS = ExceptT . convertExceptionToString . try @IOError . readFile
+
+getVal :: String -> String -> M.Map String String -> Either String String
+getVal msg k kvmap = maybeToEither msg $ M.lookup k kvmap
+
+maybeToEither :: b -> Maybe a -> Either b a
+maybeToEither _ (Just a) = Right a
+maybeToEither b Nothing = Left b
+
+doParseFile :: String -> ExceptT String IO DotDesktopApp
+doParseFile filePath = do
+  content <- doReadFileLBS filePath
+  parsed <- liftEither $ runDotDesktopParser content
+  let kvMaybe = snd <$> listToMaybe (rights parsed)
+  keyVals <- liftEither $
+    maybe
+      (Left $ "Parse Resulted in no KeyVals in file " ++ filePath)
+      Right
+      kvMaybe
+  let errMsg = "Unable to find Name in file " ++ filePath
+  nom <- liftEither $ getVal errMsg "Name" keyVals
+  exc <- liftEither $ getVal errMsg "Exec" keyVals
+  typ <- liftEither $ 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
+
+
+getAppFolders :: IO [FilePath]
+getAppFolders = do
+  xdgDataHome <- getXdgDirectory XdgData ""
+  xdgDataDirs <- getXdgDirectoryList XdgDataDirs
+  let possibleAppDirs = (xdgDataHome : xdgDataDirs) <&> (</> "applications")
+  filterM doesDirectoryExist possibleAppDirs
+
+getDirContents :: FilePath -> ExceptT String IO [FilePath]
+getDirContents dir = do
+  fn <- ExceptT . convertExceptionToString . try @IOError . listDirectory $ dir
+  return $ (dir </>) <$> fn
+
+getDotDesktopApps :: IO [DotDesktopApp]
+getDotDesktopApps = do
+  appFolders <- getAppFolders
+  contentsPerFolder <- mapM (runExceptT . getDirContents) appFolders
+  let folderFiles = join $ rights contentsPerFolder
+      dotDesktopFiles = filter isDotDesktop folderFiles
+      folderWarnings = join $ lefts contentsPerFolder
+  mapM_ print folderWarnings
+  parseResults <- mapM (runExceptT . 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 = do
+          spawn $ cmdNameMap M.! s
+    mkXPrompt Shell cfg (pure . complFunc) complAction

XMonad/Prompt/DotDesktopParser.hs

@@ -0,0 +1,171 @@
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE LambdaCase #-}
+module XMonad.Prompt.DotDesktopParser
+    ( runDotDesktopParser
+    ) where
+
+import Data.Maybe ( catMaybes )
+import Control.Monad ( MonadPlus(..) )
+import Control.Applicative ( Alternative(..) )
+import qualified Data.Map as MAP
+
+newtype Parser a = Parser { parse :: String -> [(a,String)] }
+
+runParser :: Parser a -> String -> Either String a
+runParser m s =
+  case parse m s of
+    [(res, [])] -> Right res
+    [(_, b)]    -> Left $ "Parser did not consume entire stream.  Remaining: " ++ show b -- ++ " " ++ show b
+    _           -> Left "Parser error."
+
+item :: Parser Char
+item = Parser $ \case
+   []     -> []
+   (c:cs) -> [(c,cs)]
+
+instance Functor Parser where
+  fmap f (Parser cs) = Parser (\s -> [(f a, b) | (a, b) <- cs s])
+
+instance Applicative Parser where
+  pure a = Parser (\s -> [(a,s)])
+  (Parser cs1) <*> (Parser cs2) = Parser (\s -> [(f a, s2) | (f, s1) <- cs1 s, (a, s2) <- cs2 s1])
+
+instance Monad Parser where
+  p >>= f = Parser $ \s -> concatMap (\(a, s') -> parse (f a) s') $ parse p s
+
+instance MonadPlus Parser where
+  mzero = failure
+  mplus = combine
+
+instance Alternative Parser where
+  empty = mzero
+  (<|>) = option
+
+combine :: Parser a -> Parser a -> Parser a
+combine p q = Parser (\s -> parse p s ++ parse q s)
+
+failure :: Parser a
+failure = Parser (const [])
+
+option :: Parser a -> Parser a -> Parser a
+option  p q = Parser $ \s ->
+  case parse p s of
+    []     -> parse q s
+    res    -> res
+
+satisfy :: (Char -> Bool) -> Parser Char
+satisfy p = item >>= \c ->
+  if p c
+  then return c
+  else failure
+
+type Predicate a = a -> Bool
+
+notP :: Predicate a -> Predicate a
+notP = (not .)
+
+-------------------------------------------------------------------------------
+-- Combinators
+-------------------------------------------------------------------------------
+
+oneOf :: String -> Parser Char
+oneOf s = satisfy (`elem` s)
+
+notOneOf :: String -> Parser Char
+notOneOf s = satisfy (notP (`elem` s))
+
+char :: Char -> Parser Char
+char c = satisfy (c ==)
+
+string :: String -> Parser String
+string [] = return []
+string (c:cs) = do { char c; string cs; return (c:cs)}
+
+token :: Parser a -> Parser a
+token p = do { a <- p; spaces ; return a}
+
+reserved :: String -> Parser String
+reserved s = token (string s)
+
+spaces :: Parser String
+spaces = many $ oneOf " \t"
+
+newline :: Parser Char
+newline = char '\n'
+
+squareBrackets :: Parser a -> Parser a
+squareBrackets m = do
+  reserved "["
+  n <- m
+  reserved "]"
+  return n
+
+data IniFile
+  = DesktopEntrySection String
+  | KeyValues [(String, String)]
+  deriving Show
+
+keyName :: Parser String
+keyName = some (notOneOf "=\n \t")
+
+keyValue :: Parser (String, String)
+keyValue = do
+  key <- keyName
+  spaces
+  char '='
+  spaces
+  val <- many (notOneOf "\n")
+  newline
+  return (key, val)
+
+nonSectionLine :: Parser String
+nonSectionLine = do
+  startChar <- notOneOf "["
+  otherChar <- many $ notOneOf "\n"
+  newline
+  return $ startChar : otherChar
+
+desktopEntrySectionLine :: Parser (Either String String)
+desktopEntrySectionLine = do
+  sectionName <- squareBrackets (string "Desktop Entry")
+  newline
+  return $ Right sectionName
+
+badSectionLine :: Parser (Either String String)
+badSectionLine = do
+  startChar <- char '['
+  otherChar <- many $ notOneOf "\n"
+  newline
+  return $ Left $ startChar : otherChar
+
+emptyLine :: Parser ()
+emptyLine = do
+  whitespaceLine <|> commentLine
+  return ()
+  where whitespaceLine = spaces >> newline
+        commentLine = spaces
+                   >> char '#'
+                   >> many (notOneOf "\n")
+                   >> newline
+
+sectionBodyLine :: Parser (Maybe (String, String))
+sectionBodyLine = (Just <$> keyValue)
+                  <|> (Nothing <$ emptyLine)
+
+
+section :: Parser (Either String (String, MAP.Map String String))
+section = do
+  many nonSectionLine
+  sectionLabel <- desktopEntrySectionLine <|> badSectionLine
+  keyValsList <- catMaybes <$> many sectionBodyLine
+  let keyVals = MAP.fromList keyValsList
+  return $ (,keyVals) <$> sectionLabel
+
+dotDesktopParser :: Parser [Either String (String, MAP.Map String String)]
+dotDesktopParser = do
+  sections <- many section
+  many nonSectionLine
+  return sections
+
+runDotDesktopParser :: String -> Either String [Either String (String, MAP.Map String String)]
+runDotDesktopParser = runParser dotDesktopParser

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