rofi-extras/lib/Rofi/Command.hs

module Rofi.Command
  ( RofiConf (..)
  , RofiMenu (..)
  , RofiAction
  , RofiActions
  , RofiIO
  , RofiGroup
  , Hotkey (..)
  , io
  , emptyMenu
  , runRofiIO
  , toRofiActions
  , rofiActionKeys
  , untitledGroup
  , titledGroup
  , selectAction
  , readPassword
  , readPassword'
  , readCmdSuccess
  , readCmdEither
  , readCmdEither'
  , dmenuArgs
  , joinNewline
  , stripWS
  )
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 RofiConf c where
  defArgs :: c -> [T.Text]

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

type RofiActions c = M.OMap T.Text (RofiIO 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 = []
    }

newtype RofiIO c a = RofiIO (ReaderT c IO a)
  deriving (Functor, Applicative, Monad, MonadIO, MonadReader c, MonadUnliftIO)

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

runRofiIO :: c -> RofiIO c a -> IO a
runRofiIO c (RofiIO r) = runReaderT r c

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

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

lookupRofiAction :: T.Text -> RofiActions c -> RofiIO 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 :: RofiConf c => RofiMenu c -> RofiIO 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

maybeOption :: T.Text -> Maybe T.Text -> [T.Text]
maybeOption switch = maybe [] (\o -> [switch, o])

dmenuArgs :: [T.Text]
dmenuArgs = ["-dmenu"]

readRofi
  :: RofiConf c
  => [T.Text]
  -> T.Text
  -> RofiIO 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"]