diff --git a/XMonad/Prompt/DotDesktop.hs b/XMonad/Prompt/DotDesktop.hs new file mode 100644 index 0000000000..af3f68e835 --- /dev/null +++ b/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 diff --git a/XMonad/Prompt/DotDesktopParser.hs b/XMonad/Prompt/DotDesktopParser.hs new file mode 100644 index 0000000000..0e9fb3f475 --- /dev/null +++ b/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 + diff --git a/xmonad-contrib.cabal b/xmonad-contrib.cabal index 35dc763e48..5d62066530 100644 --- a/xmonad-contrib.cabal +++ b/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