xmonad-config/lib/XMonad/Internal/Shell.hs

{-# LANGUAGE OverloadedStrings #-}

--------------------------------------------------------------------------------
-- | Functions for formatting and spawning shell commands

module XMonad.Internal.Shell
  ( fmtCmd
  , spawnCmd
  , spawn
  , doubleQuote
  , singleQuote
  , skip
  , runProcessX
  , spawnAt
  , proc'
  , shell'
  , createProcess'
  , (#!&&)
  , (#!||)
  , (#!|)
  , (#!>>)
  ) where

import           Control.Monad.IO.Class

import           RIO
import qualified RIO.Text               as T

import           System.Process

import qualified XMonad.Core            as X

--------------------------------------------------------------------------------
-- | Opening subshell

withDefaultSignalHandlers :: IO a -> IO a
withDefaultSignalHandlers =
  bracket_ X.uninstallSignalHandlers X.installSignalHandlers

addGroupSession :: CreateProcess -> CreateProcess
addGroupSession cp = cp { create_group = True, new_session = True }

createProcess' :: CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess' = withDefaultSignalHandlers . createProcess

readProcessX :: CreateProcess -> String -> IO (ExitCode, T.Text, T.Text)
readProcessX c i = withDefaultSignalHandlers $ do
  (r, e, p) <- readCreateProcessWithExitCode c i
  return (r, T.pack e, T.pack p)

runProcessX :: CreateProcess -> String -> IO ExitCode
runProcessX c i = (\(r, _, _) -> r) <$> readProcessX c i

shell' :: String -> CreateProcess
shell' = addGroupSession . shell

proc' :: FilePath -> [String] -> CreateProcess
proc' cmd args = addGroupSession $ proc cmd args

spawn :: MonadIO m => String -> m ()
spawn = liftIO . void . createProcess' . shell'

spawnAt :: MonadIO m => FilePath -> String -> m ()
spawnAt fp cmd = liftIO $ void $ createProcess' $ (shell' cmd) { cwd = Just fp }

spawnCmd :: MonadIO m => FilePath -> [T.Text] -> m ()
spawnCmd cmd args = spawn $ T.unpack $ fmtCmd cmd args

--------------------------------------------------------------------------------
-- | Formatting commands

fmtCmd :: FilePath -> [T.Text] -> T.Text
fmtCmd cmd args = T.unwords $ T.pack cmd : args

op :: T.Text -> T.Text -> T.Text -> T.Text
op a x b = T.unwords [a, x, b]

(#!&&) :: T.Text -> T.Text -> T.Text
cmdA #!&& cmdB = op cmdA "&&" cmdB

infixr 0 #!&&

(#!|) :: T.Text -> T.Text -> T.Text
cmdA #!| cmdB = op cmdA "|" cmdB

infixr 0 #!|

(#!||) :: T.Text -> T.Text -> T.Text
cmdA #!|| cmdB = op cmdA "||" cmdB

infixr 0 #!||

(#!>>) :: T.Text -> T.Text -> T.Text
cmdA #!>> cmdB = op cmdA ";" cmdB

infixr 0 #!>>

doubleQuote :: T.Text -> T.Text
doubleQuote s = T.concat ["\"", s, "\""]

singleQuote :: T.Text -> T.Text
singleQuote s = T.concat ["'", s, "'"]

skip :: Monad m => m ()
skip = return ()