rofi-extras/lib/Rofi/Command.hs

194 lines
4.8 KiB
Haskell

module Rofi.Command
( HasRofiConf (..)
, RofiMenu (..)
, RofiAction
, RofiActions
, RofiGroup
, Hotkey (..)
, io
, emptyMenu
, toRofiActions
, rofiActionKeys
, untitledGroup
, titledGroup
, selectAction
, readPassword
, readPassword'
, readCmdSuccess
, readCmdEither
, readCmdEither'
, dmenuArgs
, joinNewline
, stripWS
, runRofi
)
where
import Data.Char
import qualified Data.Map.Ordered as M
import RIO
import qualified RIO.List as L
import qualified RIO.Text as T
import System.Process
class HasRofiConf c where
defArgs :: c -> [T.Text]
type RofiAction c = (T.Text, RIO c ())
type RofiActions c = M.OMap T.Text (RIO c ())
data RofiGroup c = RofiGroup
{ actions :: RofiActions c
, title :: Maybe T.Text
}
untitledGroup :: RofiActions c -> RofiGroup c
untitledGroup a = RofiGroup {actions = a, title = Nothing}
titledGroup :: T.Text -> RofiActions c -> RofiGroup c
titledGroup t a = (untitledGroup a) {title = Just t}
data Hotkey c = Hotkey
{ keyCombo :: !T.Text
, -- only 1-10 are valid
keyIndex :: !Int
, keyDescription :: !T.Text
, keyActions :: RofiActions c
}
hotkeyBinding :: Hotkey c -> [T.Text]
hotkeyBinding Hotkey {keyIndex = e, keyCombo = c} = [k, c]
where
k = T.append "-kb-custom-" $ T.pack $ show e
hotkeyMsg1 :: Hotkey c -> T.Text
hotkeyMsg1 Hotkey {keyCombo = c, keyDescription = d} =
T.concat [c, ": <i>", d, "</i>"]
hotkeyMsg :: [Hotkey c] -> [T.Text]
hotkeyMsg [] = []
hotkeyMsg hs = ["-mesg", T.intercalate " | " $ fmap hotkeyMsg1 hs]
hotkeyArgs :: [Hotkey c] -> [T.Text]
hotkeyArgs hks = hotkeyMsg hks ++ concatMap hotkeyBinding hks
data RofiMenu c = RofiMenu
{ groups :: [RofiGroup c]
, prompt :: Maybe T.Text
, hotkeys :: [Hotkey c]
}
emptyMenu :: RofiMenu c
emptyMenu =
RofiMenu
{ groups = []
, prompt = Nothing
, hotkeys = []
}
io :: MonadIO m => IO a -> m a
io = liftIO
toRofiActions :: [(T.Text, RIO c ())] -> RofiActions c
toRofiActions = M.fromList
rofiActionKeys :: RofiActions c -> T.Text
rofiActionKeys = joinNewline . map fst . M.assocs
lookupRofiAction :: T.Text -> RofiActions c -> RIO c ()
lookupRofiAction key ras = fromMaybe (return ()) $ M.lookup key ras
groupEntries :: RofiGroup c -> T.Text
groupEntries RofiGroup {actions = a, title = t}
| null a = ""
| otherwise = T.append title' $ rofiActionKeys a
where
title' = maybe "" (`T.append` "\n") t
menuActions :: RofiMenu c -> RofiActions c
menuActions = L.foldr (M.<>|) M.empty . fmap actions . groups
menuEntries :: RofiMenu c -> T.Text
menuEntries = T.intercalate "\n\n" . filter (not . T.null) . fmap groupEntries . groups
selectAction :: HasRofiConf c => RofiMenu c -> RIO c ()
selectAction rm = do
let p = maybeOption "-p" $ prompt rm
let hArgs = hotkeyArgs $ hotkeys rm
res <- readRofi (p ++ hArgs) $ menuEntries rm
case res of
Right key -> lookupRofiAction key $ menuActions rm
Left (n, key, _) ->
mapM_ (lookupRofiAction key . keyActions) $
L.find ((==) n . (+ 9) . keyIndex) $
hotkeys rm
runRofi :: (MonadIO m, HasRofiConf c) => c -> RofiMenu c -> m ()
runRofi c = runRIO c . selectAction
maybeOption :: T.Text -> Maybe T.Text -> [T.Text]
maybeOption switch = maybe [] (\o -> [switch, o])
dmenuArgs :: [T.Text]
dmenuArgs = ["-dmenu"]
readRofi
:: HasRofiConf c
=> [T.Text]
-> T.Text
-> RIO c (Either (Int, T.Text, T.Text) T.Text)
readRofi uargs input = do
dargs <- asks defArgs
io $ readCmdEither "rofi" (dmenuArgs ++ dargs ++ uargs) input
readCmdSuccess :: T.Text -> [T.Text] -> T.Text -> IO (Maybe T.Text)
readCmdSuccess cmd args input =
either (const Nothing) Just
<$> readCmdEither cmd args input
readCmdEither
:: T.Text
-> [T.Text]
-> T.Text
-> IO (Either (Int, T.Text, T.Text) T.Text)
readCmdEither cmd args input =
resultToEither
<$> readProcessWithExitCode (T.unpack cmd) (fmap T.unpack args) (T.unpack input)
readCmdEither'
:: T.Text
-> [T.Text]
-> T.Text
-> [(T.Text, T.Text)]
-> IO (Either (Int, T.Text, T.Text) T.Text)
readCmdEither' cmd args input environ =
resultToEither
<$> readCreateProcessWithExitCode p (T.unpack input)
where
p =
(proc (T.unpack cmd) (fmap T.unpack args))
{ env = Just $ fmap (bimap T.unpack T.unpack) environ
}
resultToEither
:: (ExitCode, String, String)
-> Either (Int, T.Text, T.Text) T.Text
resultToEither (ExitSuccess, out, _) = Right $ stripWS $ T.pack out
resultToEither (ExitFailure n, out, err) =
Left (n, stripWS $ T.pack out, stripWS $ T.pack err)
stripWS :: T.Text -> T.Text
stripWS = T.reverse . T.dropWhile isSpace . T.reverse
joinNewline :: [T.Text] -> T.Text
joinNewline = T.intercalate "\n"
readPassword :: IO (Maybe T.Text)
readPassword = readPassword' "Password"
readPassword' :: T.Text -> IO (Maybe T.Text)
readPassword' p = readCmdSuccess "rofi" args ""
where
args = dmenuArgs ++ ["-p", p, "-password"]