xmonad-config/lib/XMonad/Internal/Command/DMenu.hs

248 lines
6.8 KiB
Haskell
Raw Normal View History

2020-04-01 22:06:00 -04:00
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- Dmenu (Rofi) Commands
2020-04-01 22:06:00 -04:00
2020-04-01 20:17:47 -04:00
module XMonad.Internal.Command.DMenu
( runCmdMenu
, runAppMenu
, runClipMenu
, runWinMenu
, runNetMenu
, runDevMenu
2020-05-02 00:02:29 -04:00
, runBwMenu
2021-12-15 00:30:18 -05:00
, runVPNMenu
2021-11-29 00:56:16 -05:00
, runBTMenu
2020-04-01 20:17:47 -04:00
, runShowKeys
2020-08-17 18:46:02 -04:00
, runAutorandrMenu
2022-12-30 14:58:23 -05:00
)
where
import DBus
2023-01-02 19:44:17 -05:00
import qualified Data.ByteString.Char8 as BC
2022-12-30 14:58:23 -05:00
import Data.Internal.DBus
2023-01-01 18:33:02 -05:00
import Data.Internal.XIO
2022-12-30 14:58:23 -05:00
import Graphics.X11.Types
2023-01-02 19:44:17 -05:00
import RIO
import qualified RIO.ByteString as B
2022-12-31 19:47:02 -05:00
import RIO.Directory
2022-12-30 14:58:23 -05:00
( XdgDirectory (..)
, getXdgDirectory
)
2022-12-31 19:47:02 -05:00
import qualified RIO.Text as T
2023-01-02 19:44:17 -05:00
-- import System.IO
2022-12-30 14:58:23 -05:00
import XMonad.Core hiding (spawn)
import XMonad.Internal.Command.Desktop
import XMonad.Internal.DBus.Common
import XMonad.Internal.Notify
import XMonad.Internal.Shell
import XMonad.Util.NamedActions
2020-04-01 22:06:00 -04:00
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- DMenu executables
2020-04-01 22:06:00 -04:00
myDmenuCmd :: FilePath
myDmenuCmd = "rofi"
myDmenuDevices :: FilePath
2021-06-19 00:17:47 -04:00
myDmenuDevices = "rofi-dev"
myDmenuPasswords :: FilePath
2021-06-19 00:17:47 -04:00
myDmenuPasswords = "rofi-bw"
myDmenuBluetooth :: FilePath
2021-11-29 00:56:16 -05:00
myDmenuBluetooth = "rofi-bt"
myDmenuVPN :: FilePath
2021-12-15 00:30:18 -05:00
myDmenuVPN = "rofi-evpn"
myDmenuMonitors :: FilePath
2021-06-19 00:17:47 -04:00
myDmenuMonitors = "rofi-autorandr"
myDmenuNetworks :: FilePath
2021-06-19 00:17:47 -04:00
myDmenuNetworks = "networkmanager_dmenu"
myClipboardManager :: FilePath
2022-07-03 01:11:32 -04:00
myClipboardManager = "greenclip"
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- Packages
dmenuPkgs :: [Fulfillment]
dmenuPkgs = [Package Official "rofi"]
clipboardPkgs :: [Fulfillment]
clipboardPkgs = [Package AUR "rofi-greenclip"]
2021-06-19 00:17:47 -04:00
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- Other internal functions
2021-06-19 00:17:47 -04:00
2023-01-02 19:32:12 -05:00
spawnDmenuCmd :: MonadUnliftIO m => T.Text -> [T.Text] -> Sometimes (m ())
spawnDmenuCmd n =
sometimesExeArgs n "rofi preset" dmenuPkgs True myDmenuCmd
2020-04-01 22:06:00 -04:00
themeArgs :: T.Text -> [T.Text]
2020-08-15 17:00:13 -04:00
themeArgs hexColor =
[ "-theme-str"
, T.concat ["'#element.selected.normal { background-color: ", hexColor, "; }'"]
2020-08-15 17:00:13 -04:00
]
myDmenuMatchingArgs :: [T.Text]
2020-08-15 17:00:13 -04:00
myDmenuMatchingArgs = ["-i"] -- case insensitivity
dmenuTree :: IOTree_ -> IOTree_
dmenuTree = And_ $ Only_ dmenuDep
dmenuDep :: IODependency_
dmenuDep = sysExe dmenuPkgs myDmenuCmd
2020-04-01 22:06:00 -04:00
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- Exported Commands
2020-04-01 22:06:00 -04:00
2022-07-07 01:05:17 -04:00
-- TODO test that veracrypt and friends are installed
2023-01-02 19:32:12 -05:00
runDevMenu :: MonadUnliftIO m => Sometimes (m ())
2022-07-02 17:09:21 -04:00
runDevMenu = sometimesIO_ "device manager" "rofi devices" t x
2022-06-28 23:27:55 -04:00
where
t = dmenuTree $ Only_ (localExe [] myDmenuDevices)
2022-06-28 23:27:55 -04:00
x = do
c <- io $ getXdgDirectory XdgConfig "rofi/devices.dhall"
2022-12-30 14:58:23 -05:00
spawnCmd myDmenuDevices $
["-c", T.pack c]
++ "--"
: themeArgs "#999933"
++ myDmenuMatchingArgs
2020-05-02 00:02:29 -04:00
2022-07-07 01:05:17 -04:00
-- TODO test that bluetooth interface exists
2023-01-02 19:32:12 -05:00
runBTMenu :: MonadUnliftIO m => Sometimes (m ())
2022-12-30 14:58:23 -05:00
runBTMenu =
Sometimes
"bluetooth selector"
xpfBluetooth
[Subfeature (IORoot_ cmd tree) "rofi bluetooth"]
where
2022-12-30 14:58:23 -05:00
cmd = spawnCmd myDmenuBluetooth $ "-c" : themeArgs "#0044bb"
tree = dmenuTree $ Only_ $ sysExe [] myDmenuBluetooth
2021-11-29 00:56:16 -05:00
2023-01-02 19:32:12 -05:00
runVPNMenu :: MonadUnliftIO m => Sometimes (m ())
2022-12-30 14:58:23 -05:00
runVPNMenu =
Sometimes
"VPN selector"
xpfVPN
[Subfeature (IORoot_ cmd tree) "rofi VPN"]
2022-07-08 00:21:05 -04:00
where
2022-12-30 14:58:23 -05:00
cmd =
spawnCmd myDmenuVPN $
["-c"] ++ themeArgs "#007766" ++ myDmenuMatchingArgs
tree =
dmenuTree $
toAnd_ (localExe [] myDmenuVPN) $
socketExists "expressVPN" [] $
return "/var/lib/expressvpn/expressvpnd.socket"
2021-12-15 00:30:18 -05:00
2023-01-02 19:32:12 -05:00
runCmdMenu :: MonadUnliftIO m => Sometimes (m ())
runCmdMenu = spawnDmenuCmd "command menu" ["-show", "run"]
2023-01-02 19:32:12 -05:00
runAppMenu :: MonadUnliftIO m => Sometimes (m ())
runAppMenu = spawnDmenuCmd "app launcher" ["-show", "drun"]
2023-01-02 19:32:12 -05:00
runWinMenu :: MonadUnliftIO m => Sometimes (m ())
runWinMenu = spawnDmenuCmd "window switcher" ["-show", "window"]
2023-10-27 23:12:22 -04:00
runNetMenu :: MonadUnliftIO m => Maybe NamedSysConnection -> Sometimes (m ())
2022-12-30 14:58:23 -05:00
runNetMenu cl =
Sometimes
"network control menu"
enabled
[Subfeature root "network control menu"]
2022-07-08 00:21:05 -04:00
where
enabled f = xpfEthernet f || xpfWireless f || xpfVPN f
root = DBusRoot_ cmd tree cl
2022-07-08 00:21:05 -04:00
cmd _ = spawnCmd myDmenuNetworks $ themeArgs "#ff3333"
2022-12-30 14:58:23 -05:00
tree =
And_ (Only_ $ Bus networkManagerPkgs networkManagerBus) $
toAnd_ (DBusIO dmenuDep) $
DBusIO $
sysExe [Package AUR "networkmanager-dmenu-git"] myDmenuNetworks
2020-08-17 18:46:02 -04:00
2023-01-02 19:32:12 -05:00
runAutorandrMenu :: MonadUnliftIO m => Sometimes (m ())
runAutorandrMenu = sometimesIO_ "autorandr menu" "rofi autorandr" tree cmd
where
cmd = spawnCmd myDmenuMonitors $ themeArgs "#ff0066"
tree = dmenuTree $ Only_ $ localExe [] myDmenuMonitors
2022-07-03 01:11:32 -04:00
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- Password manager
2022-07-03 01:11:32 -04:00
2023-10-27 23:12:22 -04:00
runBwMenu :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
2022-07-08 00:21:05 -04:00
runBwMenu cl = sometimesDBus cl "password manager" "rofi bitwarden" tree cmd
where
2022-12-30 14:58:23 -05:00
cmd _ =
spawnCmd myDmenuPasswords $
["-c"] ++ themeArgs "#bb6600" ++ myDmenuMatchingArgs
tree =
And_ (Only_ $ Bus [] $ busName_ "org.rofi.bitwarden") $
toAnd_ (DBusIO dmenuDep) (DBusIO $ localExe [] myDmenuPasswords)
2022-07-03 01:11:32 -04:00
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- Clipboard
2022-07-03 01:11:32 -04:00
2023-01-02 19:32:12 -05:00
runClipMenu :: MonadUnliftIO m => Sometimes (m ())
2022-07-03 01:11:32 -04:00
runClipMenu = sometimesIO_ "clipboard manager" "rofi greenclip" tree act
where
act = spawnCmd myDmenuCmd args
2022-12-30 14:58:23 -05:00
tree =
listToAnds
dmenuDep
[ sysExe clipboardPkgs myClipboardManager
, process [] $ T.pack myClipboardManager
]
args =
[ "-modi"
, "\"clipboard:greenclip print\""
, "-show"
, "clipboard"
, "-run-command"
, "'{cmd}'"
]
++ themeArgs "#00c44e"
2022-07-03 01:11:32 -04:00
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- Shortcut menu
2023-01-02 19:44:17 -05:00
runShowKeys
2023-02-12 23:08:05 -05:00
:: (MonadReader env m, MonadUnliftIO m)
2023-01-02 19:44:17 -05:00
=> Always ([((KeyMask, KeySym), NamedAction)] -> m ())
2022-12-30 14:58:23 -05:00
runShowKeys =
Always "keyboard menu" $
Option showKeysDMenu $
Always_ $
FallbackAlone fallback
where
-- TODO this should technically depend on dunst
2022-12-30 14:58:23 -05:00
fallback =
const $
spawnNotify $
defNoteError {body = Just $ Text "could not display keymap"}
2023-01-02 19:44:17 -05:00
showKeysDMenu
2023-02-12 23:08:05 -05:00
:: (MonadReader env m, MonadUnliftIO m)
2023-01-02 19:44:17 -05:00
=> SubfeatureRoot ([((KeyMask, KeySym), NamedAction)] -> m ())
2022-12-30 14:58:23 -05:00
showKeysDMenu =
Subfeature
{ sfName = "keyboard shortcut menu"
, sfData = IORoot_ showKeys $ Only_ dmenuDep
}
2023-01-02 19:55:44 -05:00
showKeys
2023-02-12 23:08:05 -05:00
:: (MonadReader env m, MonadUnliftIO m)
2023-01-02 19:55:44 -05:00
=> [((KeyMask, KeySym), NamedAction)]
-> m ()
showKeys kbs = do
h <- spawnPipe cmd
2023-01-02 19:44:17 -05:00
B.hPut h $ BC.unlines $ BC.pack <$> showKm kbs
hClose h
where
2022-12-30 14:58:23 -05:00
cmd =
fmtCmd myDmenuCmd $
["-dmenu", "-p", "commands"]
++ themeArgs "#7f66ff"
++ myDmenuMatchingArgs