From 504167fa57c5000a330b9656ed664df62290842e Mon Sep 17 00:00:00 2001
From: tulthix <tulthix@gmail.com>
Date: Fri, 19 Nov 2021 21:31:53 -0600
Subject: [PATCH 1/5] add .desktop prompt launcher

---
 XMonad/Prompt/DotDesktop.hs       | 146 +++++++++++++++++++++++++
 XMonad/Prompt/DotDesktopParser.hs | 171 ++++++++++++++++++++++++++++++
 xmonad-contrib.cabal              |   2 +
 3 files changed, 319 insertions(+)
 create mode 100644 XMonad/Prompt/DotDesktop.hs
 create mode 100644 XMonad/Prompt/DotDesktopParser.hs

diff --git a/XMonad/Prompt/DotDesktop.hs b/XMonad/Prompt/DotDesktop.hs
new file mode 100644
index 0000000000..780a00074c
--- /dev/null
+++ b/XMonad/Prompt/DotDesktop.hs
@@ -0,0 +1,146 @@
+{-# 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), split )
+import XMonad.Prompt.DotDesktopParser ( runDotDesktopParser )
+
+import qualified Data.Map as M
+import Control.Applicative ( Alternative((<|>)) )
+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 ( fromMaybe, maybeToList, listToMaybe )
+import System.Directory (listDirectory, doesDirectoryExist)
+import System.Environment ( lookupEnv )
+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
+
+getXdgDataHome :: IO (Maybe FilePath)
+getXdgDataHome = do
+  envXdgDataHome <- envXdgDataHomeIO
+  defaultXdgDataHome <- defaultXdgDataHomeIO
+  return $ envXdgDataHome <|> defaultXdgDataHome
+  where
+    defaultXdgDataHomeIO = lookupEnv "HOME" <&> fmap (</> ".local" </> "share")
+    envXdgDataHomeIO = lookupEnv "XDG_DATA_HOME"
+
+getXdgDataDirs :: IO [FilePath]
+getXdgDataDirs =
+  fromMaybe defaultXdgDataDirs <$> envXdgDataDirsIO
+  where
+    defaultXdgDataDirs = split ':' "/usr/local/share:/usr/share"
+    envXdgDataDirsIO = lookupEnv "XDG_DATA_DIRS" <&> (<&> split ':')
+
+getAppFolders :: IO [FilePath]
+getAppFolders = do
+  xdgDataHome <- maybeToList <$> getXdgDataHome
+  xdgDataDirs <- getXdgDataDirs
+  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
diff --git a/XMonad/Prompt/DotDesktopParser.hs b/XMonad/Prompt/DotDesktopParser.hs
new file mode 100644
index 0000000000..56d88021d8
--- /dev/null
+++ b/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
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

From 65e1a4e23b0221572cc25be2bbb0fb9b024810c8 Mon Sep 17 00:00:00 2001
From: tulthix <tulthix@gmail.com>
Date: Sun, 21 Nov 2021 09:33:27 -0600
Subject: [PATCH 2/5] use directory built in get xdg folders

---
 XMonad/Prompt/DotDesktop.hs | 29 ++++++-----------------------
 1 file changed, 6 insertions(+), 23 deletions(-)

diff --git a/XMonad/Prompt/DotDesktop.hs b/XMonad/Prompt/DotDesktop.hs
index 780a00074c..b829066e15 100644
--- a/XMonad/Prompt/DotDesktop.hs
+++ b/XMonad/Prompt/DotDesktop.hs
@@ -6,20 +6,18 @@ module XMonad.Prompt.DotDesktop
 
 import XMonad ( spawn, io, X )
 import XMonad.Prompt ( mkXPrompt, XPConfig(searchPredicate) )
-import XMonad.Prompt.Shell ( Shell(Shell), split )
+import XMonad.Prompt.Shell ( Shell(Shell) )
 import XMonad.Prompt.DotDesktopParser ( runDotDesktopParser )
 
 import qualified Data.Map as M
-import Control.Applicative ( Alternative((<|>)) )
 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 ( fromMaybe, maybeToList, listToMaybe )
-import System.Directory (listDirectory, doesDirectoryExist)
-import System.Environment ( lookupEnv )
+import Data.Maybe ( listToMaybe )
+import System.Directory (listDirectory, doesDirectoryExist, getXdgDirectory, XdgDirectory (XdgData), XdgDirectoryList (XdgDataDirs), getXdgDirectoryList)
 import System.FilePath ((</>))
 
 import Data.Char (isSpace)
@@ -91,27 +89,12 @@ data DotDesktopApp = DotDesktopApp { fileName :: String
                              , cmd :: String
                              } deriving Show
 
-getXdgDataHome :: IO (Maybe FilePath)
-getXdgDataHome = do
-  envXdgDataHome <- envXdgDataHomeIO
-  defaultXdgDataHome <- defaultXdgDataHomeIO
-  return $ envXdgDataHome <|> defaultXdgDataHome
-  where
-    defaultXdgDataHomeIO = lookupEnv "HOME" <&> fmap (</> ".local" </> "share")
-    envXdgDataHomeIO = lookupEnv "XDG_DATA_HOME"
-
-getXdgDataDirs :: IO [FilePath]
-getXdgDataDirs =
-  fromMaybe defaultXdgDataDirs <$> envXdgDataDirsIO
-  where
-    defaultXdgDataDirs = split ':' "/usr/local/share:/usr/share"
-    envXdgDataDirsIO = lookupEnv "XDG_DATA_DIRS" <&> (<&> split ':')
 
 getAppFolders :: IO [FilePath]
 getAppFolders = do
-  xdgDataHome <- maybeToList <$> getXdgDataHome
-  xdgDataDirs <- getXdgDataDirs
-  let possibleAppDirs = xdgDataHome ++ xdgDataDirs <&> (</> "applications")
+  xdgDataHome <- getXdgDirectory XdgData ""
+  xdgDataDirs <- getXdgDirectoryList XdgDataDirs
+  let possibleAppDirs = (xdgDataHome : xdgDataDirs) <&> (</> "applications")
   filterM doesDirectoryExist possibleAppDirs
 
 getDirContents :: FilePath -> ExceptT String IO [FilePath]

From bf6a12825502d89fb9e49963d0cbbbc0fea894ad Mon Sep 17 00:00:00 2001
From: tulthix <tulthix@gmail.com>
Date: Sun, 21 Nov 2021 10:13:50 -0600
Subject: [PATCH 3/5] purge ExceptT as it is not really needed

---
 XMonad/Prompt/DotDesktop.hs | 45 ++++++++++++++++++-------------------
 1 file changed, 22 insertions(+), 23 deletions(-)

diff --git a/XMonad/Prompt/DotDesktop.hs b/XMonad/Prompt/DotDesktop.hs
index b829066e15..94e3d21ea4 100644
--- a/XMonad/Prompt/DotDesktop.hs
+++ b/XMonad/Prompt/DotDesktop.hs
@@ -11,8 +11,6 @@ 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 )
@@ -51,8 +49,8 @@ convertExceptionToStringHelper = either (Left . convertExceptionToStringHelperHe
 convertExceptionToStringHelperHelper :: Exception e => e -> String
 convertExceptionToStringHelperHelper = show :: Exception e => e -> String
 
-doReadFileLBS :: String -> ExceptT String IO String
-doReadFileLBS = ExceptT . convertExceptionToString . try @IOError . readFile
+doReadFileLBS :: String -> IO (Either String String)
+doReadFileLBS = convertExceptionToString . try @IOError . readFile
 
 getVal :: String -> String -> M.Map String String -> Either String String
 getVal msg k kvmap = maybeToEither msg $ M.lookup k kvmap
@@ -61,20 +59,23 @@ 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
+doParseFile :: String -> IO (Either String DotDesktopApp)
+doParseFile filePath = doReadFileLBS filePath
+                   <&> (>>= doParseContent filePath)
+
+doParseContent :: String -> String -> Either String DotDesktopApp
+doParseContent filePath content = do
+  parsed <- runDotDesktopParser content
   let kvMaybe = snd <$> listToMaybe (rights parsed)
-  keyVals <- liftEither $
+  keyVals <-
     maybe
-      (Left $ "Parse Resulted in no KeyVals in file " ++ filePath)
-      Right
-      kvMaybe
+    (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
+  nom <- getVal errMsg "Name" keyVals
+  exc <- getVal errMsg "Exec" keyVals
+  typ <- getVal errMsg "Type" keyVals
   return DotDesktopApp { fileName = filePath
                        , name = nom
                        , type_ = typ
@@ -89,7 +90,6 @@ data DotDesktopApp = DotDesktopApp { fileName :: String
                              , cmd :: String
                              } deriving Show
 
-
 getAppFolders :: IO [FilePath]
 getAppFolders = do
   xdgDataHome <- getXdgDirectory XdgData ""
@@ -97,20 +97,20 @@ getAppFolders = do
   let possibleAppDirs = (xdgDataHome : xdgDataDirs) <&> (</> "applications")
   filterM doesDirectoryExist possibleAppDirs
 
-getDirContents :: FilePath -> ExceptT String IO [FilePath]
+getDirContents :: FilePath -> IO (Either String [FilePath])
 getDirContents dir = do
-  fn <- ExceptT . convertExceptionToString . try @IOError . listDirectory $ dir
-  return $ (dir </>) <$> fn
+  fn <- convertExceptionToString . try @IOError . listDirectory $ dir
+  return $ (fmap . fmap) (dir </>) fn
 
 getDotDesktopApps :: IO [DotDesktopApp]
 getDotDesktopApps = do
   appFolders <- getAppFolders
-  contentsPerFolder <- mapM (runExceptT . getDirContents) appFolders
+  contentsPerFolder <- mapM getDirContents appFolders
   let folderFiles = join $ rights contentsPerFolder
       dotDesktopFiles = filter isDotDesktop folderFiles
       folderWarnings = join $ lefts contentsPerFolder
   mapM_ print folderWarnings
-  parseResults <- mapM (runExceptT . doParseFile) dotDesktopFiles
+  parseResults <- mapM doParseFile dotDesktopFiles
   let parseErrs = lefts parseResults
       dotDesktopApps = rights parseResults
   mapM_ print parseErrs
@@ -124,6 +124,5 @@ appLaunchPrompt cfg = do
         complFunc s = filter (searchPredicate cfg s) cmdNameMapKeys
         --
         complAction :: String -> X ()
-        complAction s = do
-          spawn $ cmdNameMap M.! s
+        complAction s = spawn $ cmdNameMap M.! s
     mkXPrompt Shell cfg (pure . complFunc) complAction

From e36e0610c69591b0b2692a3c02242aae409dfff1 Mon Sep 17 00:00:00 2001
From: tulthix <tulthix@gmail.com>
Date: Sun, 21 Nov 2021 10:20:41 -0600
Subject: [PATCH 4/5] use suggested cleaner exception to string handler

---
 XMonad/Prompt/DotDesktop.hs | 14 ++++----------
 1 file changed, 4 insertions(+), 10 deletions(-)

diff --git a/XMonad/Prompt/DotDesktop.hs b/XMonad/Prompt/DotDesktop.hs
index 94e3d21ea4..716a9ec4a3 100644
--- a/XMonad/Prompt/DotDesktop.hs
+++ b/XMonad/Prompt/DotDesktop.hs
@@ -40,17 +40,11 @@ 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
+exceptionToString :: Exception e => Either e a -> Either String a
+exceptionToString = either (Left . show) Right
 
 doReadFileLBS :: String -> IO (Either String String)
-doReadFileLBS = convertExceptionToString . try @IOError . readFile
+doReadFileLBS = fmap exceptionToString . try @IOError . readFile
 
 getVal :: String -> String -> M.Map String String -> Either String String
 getVal msg k kvmap = maybeToEither msg $ M.lookup k kvmap
@@ -99,7 +93,7 @@ getAppFolders = do
 
 getDirContents :: FilePath -> IO (Either String [FilePath])
 getDirContents dir = do
-  fn <- convertExceptionToString . try @IOError . listDirectory $ dir
+  fn <- fmap exceptionToString . try @IOError . listDirectory $ dir
   return $ (fmap . fmap) (dir </>) fn
 
 getDotDesktopApps :: IO [DotDesktopApp]

From fe530972e20fadc7327d199a71c0cb3a989004e1 Mon Sep 17 00:00:00 2001
From: tulthix <tulthix@gmail.com>
Date: Sun, 21 Nov 2021 17:20:43 -0600
Subject: [PATCH 5/5] use ReadP parser.  move parse-related code to
 DotDesktopParser

---
 XMonad/Prompt/DotDesktop.hs       |  73 ++--------
 XMonad/Prompt/DotDesktopParser.hs | 217 +++++++++++++-----------------
 2 files changed, 109 insertions(+), 181 deletions(-)

diff --git a/XMonad/Prompt/DotDesktop.hs b/XMonad/Prompt/DotDesktop.hs
index 716a9ec4a3..af3f68e835 100644
--- a/XMonad/Prompt/DotDesktop.hs
+++ b/XMonad/Prompt/DotDesktop.hs
@@ -7,83 +7,38 @@ module XMonad.Prompt.DotDesktop
 import XMonad ( spawn, io, X )
 import XMonad.Prompt ( mkXPrompt, XPConfig(searchPredicate) )
 import XMonad.Prompt.Shell ( Shell(Shell) )
-import XMonad.Prompt.DotDesktopParser ( runDotDesktopParser )
+import XMonad.Prompt.DotDesktopParser ( doParseContent
+                                      , DotDesktopApp (..) )
 
 import qualified Data.Map as M
-import Control.Monad (filterM)
+import Control.Monad ( filterM )
 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)
+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"
 
-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 "" = ""
-
 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
 
-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 -> IO (Either String DotDesktopApp)
 doParseFile filePath = doReadFileLBS filePath
                    <&> (>>= doParseContent filePath)
 
-doParseContent :: String -> String -> Either String DotDesktopApp
-doParseContent filePath content = do
-  parsed <- runDotDesktopParser content
-  let kvMaybe = snd <$> listToMaybe (rights parsed)
-  keyVals <-
-    maybe
-    (Left $ "Parse Resulted in no KeyVals in file " ++ filePath)
-    Right
-    kvMaybe
-  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
-
 getAppFolders :: IO [FilePath]
 getAppFolders = do
   xdgDataHome <- getXdgDirectory XdgData ""
diff --git a/XMonad/Prompt/DotDesktopParser.hs b/XMonad/Prompt/DotDesktopParser.hs
index 56d88021d8..0e9fb3f475 100644
--- a/XMonad/Prompt/DotDesktopParser.hs
+++ b/XMonad/Prompt/DotDesktopParser.hs
@@ -1,171 +1,144 @@
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE LambdaCase #-}
 module XMonad.Prompt.DotDesktopParser
-    ( runDotDesktopParser
+    ( doParseContent
+    , DotDesktopApp (..)
     ) where
 
-import Data.Maybe ( catMaybes )
-import Control.Monad ( MonadPlus(..) )
-import Control.Applicative ( Alternative(..) )
+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
-
-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
+import Control.Monad ( (>=>), void )
+import Data.Char ( isSpace )
+import Data.List ( dropWhileEnd )
 
 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 :: String -> ReadP 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
+newline :: ReadP ()
+newline = void (char '\n')
 
-data IniFile
-  = DesktopEntrySection String
-  | KeyValues [(String, String)]
-  deriving Show
+squareBrackets :: ReadP a -> ReadP a
+squareBrackets = between (char '[') (char ']')
 
-keyName :: Parser String
-keyName = some (notOneOf "=\n \t")
+keyName :: ReadP String
+keyName = many1 (notOneOf "=\n \t")
 
-keyValue :: Parser (String, String)
+keyValue :: ReadP (String, String)
 keyValue = do
   key <- keyName
-  spaces
+  skipSpaces
   char '='
-  spaces
+  skipSpaces
   val <- many (notOneOf "\n")
-  newline
+  char '\n'
   return (key, val)
 
-nonSectionLine :: Parser String
-nonSectionLine = do
-  startChar <- notOneOf "["
-  otherChar <- many $ notOneOf "\n"
-  newline
-  return $ startChar : otherChar
-
-desktopEntrySectionLine :: Parser (Either String String)
+desktopEntrySectionLine :: ReadP (Either String String)
 desktopEntrySectionLine = do
   sectionName <- squareBrackets (string "Desktop Entry")
   newline
   return $ Right sectionName
 
-badSectionLine :: Parser (Either String String)
+badSectionLine :: ReadP (Either String String)
 badSectionLine = do
   startChar <- char '['
   otherChar <- many $ notOneOf "\n"
   newline
   return $ Left $ startChar : otherChar
 
-emptyLine :: Parser ()
+emptyLine :: ReadP ()
 emptyLine = do
-  whitespaceLine <|> commentLine
+  whitespaceLine +++ commentLine +++ newline
   return ()
-  where whitespaceLine = spaces >> newline
-        commentLine = spaces
+  where whitespaceLine = skipSpaces >> newline
+        commentLine = skipSpaces
                    >> char '#'
                    >> many (notOneOf "\n")
                    >> newline
 
-sectionBodyLine :: Parser (Maybe (String, String))
+sectionBodyLine :: ReadP (Maybe (String, String))
 sectionBodyLine = (Just <$> keyValue)
-                  <|> (Nothing <$ emptyLine)
-
+                  <++ (Nothing <$ emptyLine)
 
-section :: Parser (Either String (String, MAP.Map String String))
+section :: ReadP (Either String (String, MAP.Map String String))
 section = do
-  many nonSectionLine
-  sectionLabel <- desktopEntrySectionLine <|> badSectionLine
+  many emptyLine
+  sec <- desktopEntrySectionLine <++ badSectionLine
   keyValsList <- catMaybes <$> many sectionBodyLine
   let keyVals = MAP.fromList keyValsList
-  return $ (,keyVals) <$> sectionLabel
+  return $ (,keyVals) <$> sec
 
-dotDesktopParser :: Parser [Either String (String, MAP.Map String String)]
-dotDesktopParser = do
+dotDesktopReadP :: ReadP [Either String (String, MAP.Map String String)]
+dotDesktopReadP = do
   sections <- many section
-  many nonSectionLine
+  eof
   return sections
 
-runDotDesktopParser :: String -> Either String [Either String (String, MAP.Map String String)]
-runDotDesktopParser = runParser dotDesktopParser
+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
+