rofi-extras/lib/Rofi/Command.hs

module Rofi.Command
  ( HasRofiConf (..)
  , RofiMenu (..)
  , RofiAction
  , RofiActions
  , RofiGroup
  , Hotkey (..)
  , io
  , emptyMenu
  , toRofiActions
  , rofiActionKeys
  , untitledGroup
  , titledGroup
  , selectAction
  , readPassword
  , readPassword'
  , readCmdSuccess
  , readCmdEither
  , readCmdEither'
  , dmenuArgs
  , joinNewline
  , runRofi
  )
where

import qualified Data.Map.Ordered as OM
import RIO
import qualified RIO.List as L
import qualified RIO.Text as T
import qualified RIO.Vector.Boxed as V
import System.Process

class HasRofiConf c where
  defArgs :: c -> [T.Text]

type RofiAction c = (T.Text, RIO c ())

type RofiActions c = OM.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
  , keyDescription :: !T.Text
  , keyActions :: RofiActions c
  }

hotkeyBinding :: Int -> Hotkey c -> [T.Text]
hotkeyBinding i Hotkey {keyCombo = c} = [k, c]
  where
    k = T.append "-kb-custom-" $ T.pack $ show i

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 (uncurry hotkeyBinding) (take 19 $ zip [1 ..] hks)

data RofiMenu c = RofiMenu
  { groups :: ![RofiGroup c]
  , prompt :: !(Maybe T.Text)
  , hotkeys :: ![Hotkey c]
  }

emptyMenu :: RofiMenu c
emptyMenu =
  RofiMenu
    { groups = []
    , prompt = Nothing
    , hotkeys = mempty
    }

io :: MonadIO m => IO a -> m a
io = liftIO

toRofiActions :: [(T.Text, RIO c ())] -> RofiActions c
toRofiActions = OM.fromList

rofiActionKeys :: RofiActions c -> T.Text
rofiActionKeys = joinNewline . map fst . OM.assocs

lookupRofiAction :: T.Text -> RofiActions c -> RIO c ()
lookupRofiAction key = fromMaybe err . OM.lookup key
  where
    err = error $ T.unpack $ T.concat ["could not lookup key: '", key, "'"]

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 (OM.<>|) OM.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 (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))

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 :: MonadIO m => T.Text -> [T.Text] -> T.Text -> m (Maybe T.Text)
readCmdSuccess cmd args input =
  either (const Nothing) Just
    <$> readCmdEither cmd args input

readCmdEither
  :: MonadIO m
  => T.Text
  -> [T.Text]
  -> T.Text
  -> m (Either (Int, T.Text, T.Text) T.Text)
readCmdEither cmd args input = readCmdEither' cmd args input []

readCmdEither'
  :: MonadIO m
  => T.Text
  -> [T.Text]
  -> T.Text
  -> [(T.Text, T.Text)]
  -> m (Either (Int, T.Text, T.Text) T.Text)
readCmdEither' cmd args input environ =
  resultToEither
    <$> liftIO (readCreateProcessWithExitCode p (T.unpack input))
  where
    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}

-- TODO why strip whitespace?
resultToEither
  :: (ExitCode, String, String)
  -> Either (Int, T.Text, T.Text) T.Text
resultToEither (ExitSuccess, out, _) = Right $ T.stripEnd $ T.pack out
resultToEither (ExitFailure n, out, err) =
  Left (n, T.stripEnd $ T.pack out, T.stripEnd $ T.pack err)

joinNewline :: [T.Text] -> T.Text
joinNewline = T.intercalate "\n"

readPassword :: MonadIO m => m (Maybe T.Text)
readPassword = readPassword' "Password"

readPassword' :: MonadIO m => T.Text -> m (Maybe T.Text)
readPassword' p = readCmdSuccess "rofi" args ""
  where
    args = dmenuArgs ++ ["-p", p, "-password"]