rofi-extras/lib/Rofi/Command.hs

199 lines
5.3 KiB
Haskell
Raw Normal View History

2020-04-23 23:32:29 -04:00
module Rofi.Command
2023-02-14 22:28:26 -05:00
( HasRofiConf (..)
2023-02-13 22:19:49 -05:00
, RofiMenu (..)
2020-04-23 23:32:29 -04:00
, RofiAction
, RofiActions
2020-05-01 21:29:54 -04:00
, RofiGroup
2023-02-13 22:19:49 -05:00
, Hotkey (..)
2020-04-23 23:32:29 -04:00
, io
, emptyMenu
, toRofiActions
, rofiActionKeys
, untitledGroup
, titledGroup
, selectAction
2020-05-01 21:29:54 -04:00
, readPassword
, readPassword'
2020-04-23 23:32:29 -04:00
, readCmdSuccess
, readCmdEither
2020-05-01 21:29:54 -04:00
, readCmdEither'
2020-04-23 23:32:29 -04:00
, dmenuArgs
, joinNewline
2023-02-14 22:28:26 -05:00
, runRofi
2023-02-13 22:19:49 -05:00
)
where
2023-02-16 22:40:24 -05:00
import qualified Data.Map.Ordered as OM
2023-02-13 22:19:49 -05:00
import RIO
import qualified RIO.List as L
2023-02-13 23:31:50 -05:00
import qualified RIO.Text as T
2023-02-16 22:40:24 -05:00
import qualified RIO.Vector.Boxed as V
2023-02-13 22:19:49 -05:00
import System.Process
2020-04-23 23:32:29 -04:00
2023-02-14 22:28:26 -05:00
class HasRofiConf c where
2023-02-13 23:31:50 -05:00
defArgs :: c -> [T.Text]
2020-04-23 23:32:29 -04:00
2023-02-14 22:28:26 -05:00
type RofiAction c = (T.Text, RIO c ())
2020-04-23 23:32:29 -04:00
2023-02-16 22:40:24 -05:00
type RofiActions c = OM.OMap T.Text (RIO c ())
2020-04-23 23:32:29 -04:00
2020-05-01 21:29:54 -04:00
data RofiGroup c = RofiGroup
2023-02-13 22:19:49 -05:00
{ actions :: RofiActions c
2023-02-13 23:31:50 -05:00
, title :: Maybe T.Text
2023-02-13 22:19:49 -05:00
}
2020-04-23 23:32:29 -04:00
2020-05-01 21:29:54 -04:00
untitledGroup :: RofiActions c -> RofiGroup c
2023-02-13 22:19:49 -05:00
untitledGroup a = RofiGroup {actions = a, title = Nothing}
2020-04-23 23:32:29 -04:00
2023-02-13 23:31:50 -05:00
titledGroup :: T.Text -> RofiActions c -> RofiGroup c
2023-02-13 22:19:49 -05:00
titledGroup t a = (untitledGroup a) {title = Just t}
2020-04-23 23:32:29 -04:00
2020-05-01 21:29:54 -04:00
data Hotkey c = Hotkey
2023-02-13 23:31:50 -05:00
{ keyCombo :: !T.Text
, keyDescription :: !T.Text
2023-02-13 22:19:49 -05:00
, keyActions :: RofiActions c
}
2020-04-23 23:32:29 -04:00
2023-02-16 22:40:24 -05:00
hotkeyBinding :: Int -> Hotkey c -> [T.Text]
hotkeyBinding i Hotkey {keyCombo = c} = [k, c]
2020-04-23 23:32:29 -04:00
where
2023-02-16 22:40:24 -05:00
k = T.append "-kb-custom-" $ T.pack $ show i
2020-04-23 23:32:29 -04:00
2023-02-13 23:31:50 -05:00
hotkeyMsg1 :: Hotkey c -> T.Text
2023-02-13 22:19:49 -05:00
hotkeyMsg1 Hotkey {keyCombo = c, keyDescription = d} =
2023-02-13 23:31:50 -05:00
T.concat [c, ": <i>", d, "</i>"]
2020-04-23 23:32:29 -04:00
2023-02-13 23:31:50 -05:00
hotkeyMsg :: [Hotkey c] -> [T.Text]
2020-04-23 23:32:29 -04:00
hotkeyMsg [] = []
2023-02-13 23:31:50 -05:00
hotkeyMsg hs = ["-mesg", T.intercalate " | " $ fmap hotkeyMsg1 hs]
2020-04-23 23:32:29 -04:00
2023-02-13 23:31:50 -05:00
hotkeyArgs :: [Hotkey c] -> [T.Text]
2023-02-16 22:40:24 -05:00
hotkeyArgs hks =
(hotkeyMsg hks)
++ (concatMap (uncurry hotkeyBinding) $ take 19 $ zip [1 ..] hks)
2020-04-23 23:32:29 -04:00
2020-05-01 21:29:54 -04:00
data RofiMenu c = RofiMenu
2023-02-16 22:40:24 -05:00
{ groups :: ![RofiGroup c]
, prompt :: !(Maybe T.Text)
, hotkeys :: ![Hotkey c]
2023-02-13 22:19:49 -05:00
}
2020-04-23 23:32:29 -04:00
2020-05-01 21:29:54 -04:00
emptyMenu :: RofiMenu c
2023-02-13 22:19:49 -05:00
emptyMenu =
RofiMenu
{ groups = []
, prompt = Nothing
2023-02-16 22:40:24 -05:00
, hotkeys = mempty
2023-02-13 22:19:49 -05:00
}
2020-04-23 23:32:29 -04:00
2020-05-01 21:29:54 -04:00
io :: MonadIO m => IO a -> m a
2020-04-23 23:32:29 -04:00
io = liftIO
2023-02-14 22:28:26 -05:00
toRofiActions :: [(T.Text, RIO c ())] -> RofiActions c
2023-02-16 22:40:24 -05:00
toRofiActions = OM.fromList
2020-04-23 23:32:29 -04:00
2023-02-13 23:31:50 -05:00
rofiActionKeys :: RofiActions c -> T.Text
2023-02-16 22:40:24 -05:00
rofiActionKeys = joinNewline . map fst . OM.assocs
2020-04-23 23:32:29 -04:00
2023-02-14 22:28:26 -05:00
lookupRofiAction :: T.Text -> RofiActions c -> RIO c ()
2023-02-16 22:40:24 -05:00
lookupRofiAction key = fromMaybe err . OM.lookup key
where
err = error $ T.unpack $ T.concat ["could not lookup key: '", key, "'"]
2020-04-23 23:32:29 -04:00
2023-02-13 23:31:50 -05:00
groupEntries :: RofiGroup c -> T.Text
2023-02-13 22:19:49 -05:00
groupEntries RofiGroup {actions = a, title = t}
2020-04-23 23:32:29 -04:00
| null a = ""
2023-02-13 23:31:50 -05:00
| otherwise = T.append title' $ rofiActionKeys a
2020-04-23 23:32:29 -04:00
where
2023-02-13 23:31:50 -05:00
title' = maybe "" (`T.append` "\n") t
2020-04-23 23:32:29 -04:00
2020-05-01 21:29:54 -04:00
menuActions :: RofiMenu c -> RofiActions c
2023-02-16 22:40:24 -05:00
menuActions = L.foldr (OM.<>|) OM.empty . fmap actions . groups
2020-04-23 23:32:29 -04:00
2023-02-13 23:31:50 -05:00
menuEntries :: RofiMenu c -> T.Text
menuEntries = T.intercalate "\n\n" . filter (not . T.null) . fmap groupEntries . groups
2020-04-23 23:32:29 -04:00
2023-02-14 22:28:26 -05:00
selectAction :: HasRofiConf c => RofiMenu c -> RIO c ()
2020-04-23 23:32:29 -04:00
selectAction rm = do
let p = maybeOption "-p" $ prompt rm
let hArgs = hotkeyArgs $ hotkeys rm
res <- readRofi (p ++ hArgs) $ menuEntries rm
case res of
2023-02-13 22:19:49 -05:00
Right key -> lookupRofiAction key $ menuActions rm
2023-02-16 22:40:24 -05:00
Left (1, _, _) -> exitWith $ ExitFailure 1
Left (n, key, _) -> do
maybe
(error $ T.unpack $ T.append "could not find key index: " $ T.pack $ show n)
(lookupRofiAction key . keyActions)
-- this sketchy assumption has to do with the fact that the custom
-- keybindings are labeled 1-19 and thus need to be explicitly
-- indexed, and the program itself tells the world which key was
-- pressed via return code (any possible integer)
((V.fromList $ hotkeys rm) V.!? (n - 10))
2020-04-23 23:32:29 -04:00
2023-02-14 22:28:26 -05:00
runRofi :: (MonadIO m, HasRofiConf c) => c -> RofiMenu c -> m ()
runRofi c = runRIO c . selectAction
2023-02-13 23:31:50 -05:00
maybeOption :: T.Text -> Maybe T.Text -> [T.Text]
2020-04-23 23:32:29 -04:00
maybeOption switch = maybe [] (\o -> [switch, o])
2023-02-13 23:31:50 -05:00
dmenuArgs :: [T.Text]
2020-04-23 23:32:29 -04:00
dmenuArgs = ["-dmenu"]
2023-02-13 22:19:49 -05:00
readRofi
2023-02-14 22:28:26 -05:00
:: HasRofiConf c
2023-02-13 23:31:50 -05:00
=> [T.Text]
-> T.Text
2023-02-14 22:28:26 -05:00
-> RIO c (Either (Int, T.Text, T.Text) T.Text)
2020-04-23 23:32:29 -04:00
readRofi uargs input = do
dargs <- asks defArgs
io $ readCmdEither "rofi" (dmenuArgs ++ dargs ++ uargs) input
2023-02-22 22:44:44 -05:00
readCmdSuccess :: MonadIO m => T.Text -> [T.Text] -> T.Text -> m (Maybe T.Text)
2023-02-13 22:19:49 -05:00
readCmdSuccess cmd args input =
either (const Nothing) Just
<$> readCmdEither cmd args input
2020-04-23 23:32:29 -04:00
2023-02-13 22:19:49 -05:00
readCmdEither
2023-02-22 22:44:44 -05:00
:: MonadIO m
=> T.Text
2023-02-13 23:31:50 -05:00
-> [T.Text]
-> T.Text
2023-02-22 22:44:44 -05:00
-> m (Either (Int, T.Text, T.Text) T.Text)
2023-02-15 22:43:46 -05:00
readCmdEither cmd args input = readCmdEither' cmd args input []
2020-05-01 21:29:54 -04:00
2023-02-13 22:19:49 -05:00
readCmdEither'
2023-02-22 22:44:44 -05:00
:: MonadIO m
=> T.Text
2023-02-13 23:31:50 -05:00
-> [T.Text]
-> T.Text
-> [(T.Text, T.Text)]
2023-02-22 22:44:44 -05:00
-> m (Either (Int, T.Text, T.Text) T.Text)
2023-02-13 22:19:49 -05:00
readCmdEither' cmd args input environ =
resultToEither
2023-02-22 22:44:44 -05:00
<$> (liftIO $ readCreateProcessWithExitCode p (T.unpack input))
2020-05-01 21:29:54 -04:00
where
2023-02-15 22:43:46 -05:00
e = case environ of
[] -> Nothing
es -> Just $ fmap (bimap T.unpack T.unpack) es
p = (proc (T.unpack cmd) (fmap T.unpack args)) {env = e}
2020-05-01 21:29:54 -04:00
2023-02-16 22:40:24 -05:00
-- TODO why strip whitespace?
2023-02-13 22:19:49 -05:00
resultToEither
:: (ExitCode, String, String)
2023-02-13 23:31:50 -05:00
-> Either (Int, T.Text, T.Text) T.Text
2023-02-16 22:40:24 -05:00
resultToEither (ExitSuccess, out, _) = Right $ T.stripEnd $ T.pack out
2023-02-13 23:31:50 -05:00
resultToEither (ExitFailure n, out, err) =
2023-02-16 22:40:24 -05:00
Left (n, T.stripEnd $ T.pack out, T.stripEnd $ T.pack err)
2020-04-23 23:32:29 -04:00
2023-02-13 23:31:50 -05:00
joinNewline :: [T.Text] -> T.Text
joinNewline = T.intercalate "\n"
2020-05-01 21:29:54 -04:00
2023-02-22 22:44:44 -05:00
readPassword :: MonadIO m => m (Maybe T.Text)
readPassword = readPassword' "Password"
2023-02-22 22:44:44 -05:00
readPassword' :: MonadIO m => T.Text -> m (Maybe T.Text)
readPassword' p = readCmdSuccess "rofi" args ""
2020-05-01 21:29:54 -04:00
where
args = dmenuArgs ++ ["-p", p, "-password"]