{-# LANGUAGE InstanceSigs        #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE ScopedTypeVariables #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Util.Run
-- Description :  Several commands, as well as an EDSL, to run external processes.
-- Copyright   :  (C) 2007  Spencer Janssen, Andrea Rossato, glasser@mit.edu
--                    2022  Tony Zorman
-- License     :  BSD-style (see LICENSE)
--
-- Maintainer  :  Tony Zorman <soliditsallgood@mailbox.org>
-- Stability   :  unstable
-- Portability :  unportable
--
-- This module provides several commands to run an external process.
-- Additionally, it provides an abstraction—particularly geared towards
-- programs like terminals or Emacs—to specify these processes from
-- XMonad in a compositional way.
--
-- Originally, this module was composed of functions formerly defined in
-- "XMonad.Util.Dmenu" (by Spencer Janssen), "XMonad.Util.Dzen" (by
-- glasser\@mit.edu) and @XMonad.Util.RunInXTerm@ (by Andrea Rossato).
-----------------------------------------------------------------------------

module XMonad.Util.Run (
  -- * Usage
  -- $usage
  runProcessWithInput,
  runProcessWithInputAndWait,
  safeSpawn,
  safeSpawnProg,
  unsafeSpawn,
  runInTerm,
  safeRunInTerm,
  seconds,
  spawnPipe,
  spawnPipeWithLocaleEncoding,
  spawnPipeWithUtf8Encoding,
  spawnPipeWithNoEncoding,

  -- * Compositionally Spawning Processes #EDSL#
  -- $EDSL

  -- ** Configuration and Running
  ProcessConfig (..),
  Input,
  spawnExternalProcess,
  proc,
  getInput,
  toInput,

  -- ** Programs
  inEditor,
  inTerm,
  termInDir,
  inProgram,

  -- ** General Combinators
  (>->),
  (>-$),
  (>&&>),
  (>||>),
  inWorkingDir,
  eval,
  execute,
  executeNoQuote,
  setXClass,
  asString,

  -- ** Emacs Integration
  EmacsLib (..),
  setFrameName,
  withEmacsLibs,
  inEmacs,
  elispFun,
  asBatch,
  require,
  progn,
  quote,
  findFile,
  list,
  saveExcursion,

  -- * Re-exports
  hPutStr,
  hPutStrLn,
) where

import XMonad
import XMonad.Prelude
import qualified XMonad.Util.ExtensibleConf as XC

import Codec.Binary.UTF8.String (encodeString)
import Control.Concurrent (threadDelay)
import System.Directory (getDirectoryContents)
import System.IO
import System.Posix.IO
import System.Posix.Process (createSession, executeFile, forkProcess)
import System.Process (runInteractiveProcess)

{- $usage

You can use this module by importing it in your @xmonad.hs@

> import XMonad.Util.Run

It then all depends on what you want to do:

  - If you want to compositionally spawn programs, see [the relevant
    extended documentation](#g:EDSL).

  - For an example usage of 'runInTerm' see "XMonad.Prompt.Ssh".

  - For an example usage of 'runProcessWithInput' see
    "XMonad.Util.Dmenu", or "XMonad.Prompt.Shell".

  - For an example usage of 'runProcessWithInputAndWait' see
    "XMonad.Util.Dzen".
-}

-- | Returns the output.
runProcessWithInput :: MonadIO m => FilePath -> [String] -> String -> m String
runProcessWithInput :: forall (m :: * -> *).
MonadIO m =>
String -> [String] -> String -> m String
runProcessWithInput String
cmd [String]
args String
input = IO String -> m String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO String -> m String) -> IO String -> m String
forall a b. (a -> b) -> a -> b
$ do
    (Handle
pin, Handle
pout, Handle
perr, ProcessHandle
_) <- String
-> [String]
-> Maybe String
-> Maybe [(String, String)]
-> IO (Handle, Handle, Handle, ProcessHandle)
runInteractiveProcess (Input
encodeString String
cmd)
                                            (Input -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Input
encodeString [String]
args) Maybe String
forall a. Maybe a
Nothing Maybe [(String, String)]
forall a. Maybe a
Nothing
    Handle -> String -> IO ()
hPutStr Handle
pin String
input
    Handle -> IO ()
hClose Handle
pin
    String
output <- Handle -> IO String
hGetContents Handle
pout
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String
output String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
output) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Handle -> IO ()
hClose Handle
pout
    Handle -> IO ()
hClose Handle
perr
    -- no need to waitForProcess, we ignore SIGCHLD
    String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
output

-- | Wait is in &#956; (microseconds)
runProcessWithInputAndWait :: MonadIO m => FilePath -> [String] -> String -> Int -> m ()
runProcessWithInputAndWait :: forall (m :: * -> *).
MonadIO m =>
String -> [String] -> String -> Int -> m ()
runProcessWithInputAndWait String
cmd [String]
args String
input Int
timeout = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    ProcessID
_ <- IO () -> IO ProcessID
forall (m :: * -> *). MonadIO m => IO () -> m ProcessID
xfork (IO () -> IO ProcessID) -> IO () -> IO ProcessID
forall a b. (a -> b) -> a -> b
$ do
        (Handle
pin, Handle
pout, Handle
perr, ProcessHandle
_) <- String
-> [String]
-> Maybe String
-> Maybe [(String, String)]
-> IO (Handle, Handle, Handle, ProcessHandle)
runInteractiveProcess (Input
encodeString String
cmd)
                                            (Input -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Input
encodeString [String]
args) Maybe String
forall a. Maybe a
Nothing Maybe [(String, String)]
forall a. Maybe a
Nothing
        Handle -> String -> IO ()
hPutStr Handle
pin String
input
        Handle -> IO ()
hFlush Handle
pin
        Int -> IO ()
threadDelay Int
timeout
        Handle -> IO ()
hClose Handle
pin
        Handle -> IO ()
hClose Handle
pout
        Handle -> IO ()
hClose Handle
perr
        -- no need to waitForProcess, we ignore SIGCHLD
        () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Multiplies by ONE MILLION, for functions that take microseconds.
--
-- Use like:
--
-- > (5.5 `seconds`)
--
-- In GHC 7 and later, you must either enable the PostfixOperators extension
-- (by adding
--
-- > {-# LANGUAGE PostfixOperators #-}
--
-- to the top of your file) or use seconds in prefix form:
--
-- > seconds 5.5
seconds :: Rational -> Int
seconds :: Rational -> Int
seconds = Rational -> Int
forall a. Enum a => a -> Int
fromEnum (Rational -> Int) -> (Rational -> Rational) -> Rational -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Rational
1000000)

{- | 'safeSpawn' bypasses 'spawn', because spawn passes
strings to \/bin\/sh to be interpreted as shell commands. This is
often what one wants, but in many cases the passed string will contain
shell metacharacters which one does not want interpreted as such (URLs
particularly often have shell metacharacters like \'&\' in them). In
this case, it is more useful to specify a file or program to be run
and a string to give it as an argument so as to bypass the shell and
be certain the program will receive the string as you typed it.

Examples:

> , ((modm, xK_Print), unsafeSpawn "import -window root $HOME/xwd-$(date +%s)$$.png")
> , ((modm, xK_d    ), safeSpawn "firefox" [])

Note that the unsafeSpawn example must be unsafe and not safe because
it makes use of shell interpretation by relying on @$HOME@ and
interpolation, whereas the safeSpawn example can be safe because
Firefox doesn't need any arguments if it is just being started. -}
safeSpawn :: MonadIO m => FilePath -> [String] -> m ()
safeSpawn :: forall (m :: * -> *). MonadIO m => String -> [String] -> m ()
safeSpawn String
prog [String]
args = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IO ProcessID -> IO ()
forall {a}. IO a -> IO ()
void_ (IO ProcessID -> IO ()) -> IO ProcessID -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ProcessID
forkProcess (IO () -> IO ProcessID) -> IO () -> IO ProcessID
forall a b. (a -> b) -> a -> b
$ do
  IO ()
forall (m :: * -> *). MonadIO m => m ()
uninstallSignalHandlers
  ProcessID
_ <- IO ProcessID
createSession
  String -> Bool -> [String] -> Maybe [(String, String)] -> IO ()
forall a.
String -> Bool -> [String] -> Maybe [(String, String)] -> IO a
executeFile (Input
encodeString String
prog) Bool
True (Input -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Input
encodeString [String]
args) Maybe [(String, String)]
forall a. Maybe a
Nothing
    where void_ :: IO a -> IO ()
void_ = (IO a -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) -- TODO: replace with Control.Monad.void / void not in ghc6 apparently

-- | Simplified 'safeSpawn'; only takes a program (and no arguments):
--
-- > , ((modm, xK_d    ), safeSpawnProg "firefox")
safeSpawnProg :: MonadIO m => FilePath -> m ()
safeSpawnProg :: forall (m :: * -> *). MonadIO m => String -> m ()
safeSpawnProg = (String -> [String] -> m ()) -> [String] -> String -> m ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip String -> [String] -> m ()
forall (m :: * -> *). MonadIO m => String -> [String] -> m ()
safeSpawn []

-- | An alias for 'spawn'; the name emphasizes that one is calling out to a
--   Turing-complete interpreter which may do things one dislikes; for details, see 'safeSpawn'.
unsafeSpawn :: MonadIO m => String -> m ()
unsafeSpawn :: forall (m :: * -> *). MonadIO m => String -> m ()
unsafeSpawn = String -> m ()
forall (m :: * -> *). MonadIO m => String -> m ()
spawn

-- | Open a terminal emulator. The terminal emulator is specified in the default configuration as xterm by default. It is then
-- asked to pass the shell a command with certain options. This is unsafe in the sense of 'unsafeSpawn'
unsafeRunInTerm, runInTerm :: String -> String -> X ()
unsafeRunInTerm :: String -> String -> X ()
unsafeRunInTerm String
options String
command = (XConf -> String) -> X String
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (XConfig Layout -> String
forall (l :: * -> *). XConfig l -> String
terminal (XConfig Layout -> String)
-> (XConf -> XConfig Layout) -> XConf -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XConf -> XConfig Layout
config) X String -> (String -> X ()) -> X ()
forall a b. X a -> (a -> X b) -> X b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \String
t -> String -> X ()
forall (m :: * -> *). MonadIO m => String -> m ()
unsafeSpawn (String -> X ()) -> String -> X ()
forall a b. (a -> b) -> a -> b
$ String
t String -> Input
forall a. [a] -> [a] -> [a]
++ String
" " String -> Input
forall a. [a] -> [a] -> [a]
++ String
options String -> Input
forall a. [a] -> [a] -> [a]
++ String
" -e " String -> Input
forall a. [a] -> [a] -> [a]
++ String
command
runInTerm :: String -> String -> X ()
runInTerm = String -> String -> X ()
unsafeRunInTerm

-- | Run a given program in the preferred terminal emulator; see 'runInTerm'. This makes use of 'safeSpawn'.
safeRunInTerm :: String -> String -> X ()
safeRunInTerm :: String -> String -> X ()
safeRunInTerm String
options String
command = (XConf -> String) -> X String
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (XConfig Layout -> String
forall (l :: * -> *). XConfig l -> String
terminal (XConfig Layout -> String)
-> (XConf -> XConfig Layout) -> XConf -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XConf -> XConfig Layout
config) X String -> (String -> X ()) -> X ()
forall a b. X a -> (a -> X b) -> X b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \String
t -> String -> [String] -> X ()
forall (m :: * -> *). MonadIO m => String -> [String] -> m ()
safeSpawn String
t [String
options, String
" -e " String -> Input
forall a. [a] -> [a] -> [a]
++ String
command]

-- | Launch an external application through the system shell and
-- return a 'Handle' to its standard input. Note that the 'Handle'
-- is a text 'Handle' using the current locale encoding.
spawnPipe :: MonadIO m => String -> m Handle
spawnPipe :: forall (m :: * -> *). MonadIO m => String -> m Handle
spawnPipe = String -> m Handle
forall (m :: * -> *). MonadIO m => String -> m Handle
spawnPipeWithLocaleEncoding

-- | Same as 'spawnPipe'.
spawnPipeWithLocaleEncoding :: MonadIO m => String -> m Handle
spawnPipeWithLocaleEncoding :: forall (m :: * -> *). MonadIO m => String -> m Handle
spawnPipeWithLocaleEncoding = TextEncoding -> String -> m Handle
forall (m :: * -> *).
MonadIO m =>
TextEncoding -> String -> m Handle
spawnPipe' TextEncoding
localeEncoding

-- | Same as 'spawnPipe', but forces the UTF-8 encoding regardless of locale.
spawnPipeWithUtf8Encoding :: MonadIO m => String -> m Handle
spawnPipeWithUtf8Encoding :: forall (m :: * -> *). MonadIO m => String -> m Handle
spawnPipeWithUtf8Encoding = TextEncoding -> String -> m Handle
forall (m :: * -> *).
MonadIO m =>
TextEncoding -> String -> m Handle
spawnPipe' TextEncoding
utf8

-- | Same as 'spawnPipe', but forces the 'char8' encoding, so unicode strings
-- need 'Codec.Binary.UTF8.String.encodeString'. Should never be needed, but
-- some X functions return already encoded Strings, so it may possibly be
-- useful for someone.
spawnPipeWithNoEncoding :: MonadIO m => String -> m Handle
spawnPipeWithNoEncoding :: forall (m :: * -> *). MonadIO m => String -> m Handle
spawnPipeWithNoEncoding = TextEncoding -> String -> m Handle
forall (m :: * -> *).
MonadIO m =>
TextEncoding -> String -> m Handle
spawnPipe' TextEncoding
char8

spawnPipe' :: MonadIO m => TextEncoding -> String -> m Handle
spawnPipe' :: forall (m :: * -> *).
MonadIO m =>
TextEncoding -> String -> m Handle
spawnPipe' TextEncoding
encoding String
x = IO Handle -> m Handle
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO Handle -> m Handle) -> IO Handle -> m Handle
forall a b. (a -> b) -> a -> b
$ do
    (Fd
rd, Fd
wr) <- IO (Fd, Fd)
createPipe
    Fd -> FdOption -> Bool -> IO ()
setFdOption Fd
wr FdOption
CloseOnExec Bool
True
    Handle
h <- Fd -> IO Handle
fdToHandle Fd
wr
    Handle -> TextEncoding -> IO ()
hSetEncoding Handle
h TextEncoding
encoding
    Handle -> BufferMode -> IO ()
hSetBuffering Handle
h BufferMode
LineBuffering
    ProcessID
_ <- IO () -> IO ProcessID
forall (m :: * -> *). MonadIO m => IO () -> m ProcessID
xfork (IO () -> IO ProcessID) -> IO () -> IO ProcessID
forall a b. (a -> b) -> a -> b
$ do
          Fd
_ <- Fd -> Fd -> IO Fd
dupTo Fd
rd Fd
stdInput
          String -> Bool -> [String] -> Maybe [(String, String)] -> IO ()
forall a.
String -> Bool -> [String] -> Maybe [(String, String)] -> IO a
executeFile String
"/bin/sh" Bool
False [String
"-c", Input
encodeString String
x] Maybe [(String, String)]
forall a. Maybe a
Nothing
    Fd -> IO ()
closeFd Fd
rd
    Handle -> IO Handle
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Handle
h

{- $EDSL

To use the provided EDSL, you must first add the 'spawnExternalProcess'
combinator to your xmonad configuration, like so:

> main = xmonad $ … $ spawnExternalProcess def $ … $ def

See 'ProcessConfig' for a list of all default configuration options, in
case you'd like to change them—especially if you want to make use of the
Emacs integration.

After that, the real fun begins!  The format for spawning these
processes is always the same: a call to 'proc', its argument being a
bunch of function calls, separated by the pipe operator '(>->)'.  You
can just bind the resulting function to a key; no additional plumbing
required.  For example, using "XMonad.Util.EZConfig" syntax and with
@terminal = "alacritty"@ in you XMonad configuration, spawning a @ghci@
session with a special class name, "calculator", would look like

> ("M-y", proc $ inTerm >-> setXClass "calculator" >-> execute "ghci")

which would translate, more or less, to @\/usr\/bin\/sh -c "alacritty
--class calculator -e ghci"@.  The usefulness of this notation becomes
apparent with more complicated examples:

> proc $ inEmacs
>    >-> withEmacsLibs [OwnFile "mailboxes"]
>    >-> execute (elispFun "notmuch")
>    >-> setFrameName "mail"

This is equivalent to spawning

> emacs -l /home/slot/.config/emacs/lisp/mailboxes.el
>       -e '(notmuch)'
>       -F '(quote (name . "mail"))'

Notice how we did not have to specify the whole path to @mailboxes.el@,
since we had set the correct 'emacsLispDir' upon starting xmonad.  This
becomes especially relevant when running Emacs in batch mode, where one
has to include [M,Non-GNU]ELPA packages in the call, whose exact names
may change at any time.  Then the following

> do url <- getSelection  -- from XMonad.Util.XSelection
>    proc $ inEmacs
>       >-> withEmacsLibs [ElpaLib "dash", ElpaLib "s", OwnFile "arXiv-citation"]
>       >-> asBatch
>       >-> execute (elispFun $ "arXiv-citation" <> asString url)

becomes

> emacs -L /home/slot/.config/emacs/elpa/dash-20220417.2250
>       -L /home/slot/.config/emacs/elpa/s-20210616.619
>       -l /home/slot/.config/emacs/lisp/arXiv-citation.el
>       --batch
>       -e '(arXiv-citation "<url-in-the-primary-selection>")'

which would be quite bothersome to type indeed!

A blog post going into some more detail and also explaining how to
integrate this new language with the "XMonad.Util.NamedScratchpad"
module is available
<https://tony-zorman.com/posts/2022-05-25-calling-emacs-from-xmonad.html here>.
-}

-----------------------------------------------------------------------
-- Types and whatnot

-- | Additional information that might be useful when spawning external
-- programs.
data ProcessConfig = ProcessConfig
  { ProcessConfig -> String
editor :: !String
    -- ^ Default editor.  Defaults to @"emacsclient -c -a ''"@.
  , ProcessConfig -> String
emacsLispDir :: !FilePath
    -- ^ Directory for your custom Emacs lisp files.  Probably
    -- @user-emacs-directory@ or @user-emacs-directory/lisp@.  Defaults
    -- to @"~\/.config\/emacs\/lisp\/"@
  , ProcessConfig -> String
emacsElpaDir :: !FilePath
    -- ^ Directory for all packages from [M,Non-GNU]ELPA; probably
    -- @user-emacs-directory/elpa@.  Defaults to
    -- @"~\/.config\/emacs\/elpa"@.
  , ProcessConfig -> String
emacs :: !String
    -- ^ /Standalone/ Emacs executable; this should not be @emacsclient@
    -- since, for example, the client does not support @--batch@ mode.
    -- Defaults to @"emacs"@.
  }

-- | Given a 'ProcessConfig', remember it for spawning external
-- processes later on.
spawnExternalProcess :: ProcessConfig -> XConfig l -> XConfig l
spawnExternalProcess :: forall (l :: * -> *). ProcessConfig -> XConfig l -> XConfig l
spawnExternalProcess = (ProcessConfig -> ProcessConfig) -> XConfig l -> XConfig l
forall a (l :: * -> *).
(Default a, Typeable a) =>
(a -> a) -> XConfig l -> XConfig l
XC.modifyDef ((ProcessConfig -> ProcessConfig) -> XConfig l -> XConfig l)
-> (ProcessConfig -> ProcessConfig -> ProcessConfig)
-> ProcessConfig
-> XConfig l
-> XConfig l
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProcessConfig -> ProcessConfig -> ProcessConfig
forall a b. a -> b -> a
const

instance Default ProcessConfig where
  def :: ProcessConfig
  def :: ProcessConfig
def = ProcessConfig
    { editor :: String
editor       = String
"emacsclient -c -a ''"
    , emacsLispDir :: String
emacsLispDir = String
"~/.config/emacs/lisp/"
    , emacsElpaDir :: String
emacsElpaDir = String
"~/.config/emacs/elpa/"
    , emacs :: String
emacs        = String
"emacs"
    }

-- | Convenient type alias.
type Input = ShowS

-----------------------------------------------------------------------
-- Combinators

-- | Combine inputs together.
(>->) :: X Input -> X Input -> X Input
>-> :: X Input -> X Input -> X Input
(>->) = X Input -> X Input -> X Input
forall a. Semigroup a => a -> a -> a
(<>)
infixr 3 >->

-- | Combine an input with an ordinary string.
(>-$) :: X Input -> X String -> X Input
>-$ :: X Input -> X String -> X Input
(>-$) X Input
xi X String
xs = X Input
xi X Input -> X Input -> X Input
>-> (String -> Input) -> X String -> X Input
forall a b. (a -> b) -> X a -> X b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Input
mkDList X String
xs
infixr 3 >-$

-- | @a >&&> b@ glues the different inputs @a@ and @b@ by means of @&&@.
-- For example,
--
-- @
-- pure "do something" >&&> pure "do another thing"
-- @
--
-- would result in @do something && do another thing@ being executed by a
-- shell.
(>&&>) :: X Input -> X Input -> X Input
X Input
a >&&> :: X Input -> X Input -> X Input
>&&> X Input
b = X Input
a X Input -> X Input -> X Input
forall a. Semigroup a => a -> a -> a
<> String -> X Input
toInput String
" && " X Input -> X Input -> X Input
forall a. Semigroup a => a -> a -> a
<> X Input
b
infixr 2 >&&>

-- | Like '(>&&>)', but with @||@.
(>||>) :: X Input -> X Input -> X Input
X Input
a >||> :: X Input -> X Input -> X Input
>||> X Input
b = X Input
a X Input -> X Input -> X Input
forall a. Semigroup a => a -> a -> a
<> String -> X Input
toInput String
" || " X Input -> X Input -> X Input
forall a. Semigroup a => a -> a -> a
<> X Input
b
infixr 2 >||>

-- | Spawn a completed input.
proc :: X Input -> X ()
proc :: X Input -> X ()
proc X Input
xi = String -> X ()
forall (m :: * -> *). MonadIO m => String -> m ()
spawn (String -> X ()) -> X String -> X ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< X Input -> X String
getInput X Input
xi

-- | Create an effectful 'Input' from a 'String'.
toInput :: String -> X Input
toInput :: String -> X Input
toInput = Input -> X Input
forall a. a -> X a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Input -> X Input) -> (String -> Input) -> String -> X Input
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Input
mkDList

-- | Get the completed input string.
getInput :: X Input -> X String
getInput :: X Input -> X String
getInput X Input
xi = X Input
xi X Input -> (Input -> String) -> X String
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Input -> Input
forall a b. (a -> b) -> a -> b
$ String
"")

-- | Use the 'editor'.
inEditor :: X Input
inEditor :: X Input
inEditor = (ProcessConfig -> X Input) -> X Input
forall (m :: * -> *) a b.
(MonadReader XConf m, Typeable a, Default a) =>
(a -> m b) -> m b
XC.withDef ((ProcessConfig -> X Input) -> X Input)
-> (ProcessConfig -> X Input) -> X Input
forall a b. (a -> b) -> a -> b
$ \ProcessConfig{String
editor :: ProcessConfig -> String
editor :: String
editor} -> Input -> X Input
forall a. a -> X a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Input -> X Input) -> Input -> X Input
forall a b. (a -> b) -> a -> b
$ String -> Input
mkDList String
editor

-- | Use the 'XMonad.Core.XConfig.terminal'.
inTerm :: X Input
inTerm :: X Input
inTerm = (XConf -> Input) -> X Input
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((XConf -> Input) -> X Input) -> (XConf -> Input) -> X Input
forall a b. (a -> b) -> a -> b
$ String -> Input
mkDList (String -> Input) -> (XConf -> String) -> XConf -> Input
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XConfig Layout -> String
forall (l :: * -> *). XConfig l -> String
terminal (XConfig Layout -> String)
-> (XConf -> XConfig Layout) -> XConf -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XConf -> XConfig Layout
config

-- | Execute the argument.  Current /thing/ must support a @-e@ option.
-- For programs such as Emacs, 'eval' may be the safer option; while
-- @emacsclient@ supports @-e@, the @emacs@ executable itself does not.
--
-- Note that this function always wraps its argument in single quotes;
-- see 'executeNoQuote' for an alternative.
execute :: String -> X Input
execute :: String -> X Input
execute String
this = Input -> X Input
forall a. a -> X a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((String
" -e " String -> Input
forall a. Semigroup a => a -> a -> a
<> Input
tryQuote String
this) String -> Input
forall a. Semigroup a => a -> a -> a
<>)

-- | Like 'execute', but doesn't wrap its argument in single quotes.
executeNoQuote :: String -> X Input
executeNoQuote :: String -> X Input
executeNoQuote String
this = Input -> X Input
forall a. a -> X a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((String
" -e " String -> Input
forall a. Semigroup a => a -> a -> a
<> String
this) String -> Input
forall a. Semigroup a => a -> a -> a
<>)

-- | Eval(uate) the argument.  Current /thing/ must support a @--eval@
-- option.
eval :: String -> X Input
eval :: String -> X Input
eval String
this = Input -> X Input
forall a. a -> X a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((String
" --eval " String -> Input
forall a. Semigroup a => a -> a -> a
<> Input
tryQuote String
this) String -> Input
forall a. Semigroup a => a -> a -> a
<>)

-- | Use 'emacs'.
inEmacs :: X Input
inEmacs :: X Input
inEmacs = (ProcessConfig -> X Input) -> X Input
forall (m :: * -> *) a b.
(MonadReader XConf m, Typeable a, Default a) =>
(a -> m b) -> m b
XC.withDef ((ProcessConfig -> X Input) -> X Input)
-> (ProcessConfig -> X Input) -> X Input
forall a b. (a -> b) -> a -> b
$ \ProcessConfig{String
emacs :: ProcessConfig -> String
emacs :: String
emacs} -> Input -> X Input
forall a. a -> X a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Input -> X Input) -> Input -> X Input
forall a b. (a -> b) -> a -> b
$ String -> Input
mkDList String
emacs

-- | Use the given program.
inProgram :: String -> X Input
inProgram :: String -> X Input
inProgram = Input -> X Input
forall a. a -> X a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Input -> X Input) -> (String -> Input) -> String -> X Input
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Input
mkDList

-- | Spawn /thing/ in the current working directory.  /thing/ must
-- support a @--working-directory@ option.
inWorkingDir :: X Input
inWorkingDir :: X Input
inWorkingDir = Input -> X Input
forall a. a -> X a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
" --working-directory " String -> Input
forall a. Semigroup a => a -> a -> a
<>)

-- | Set a frame name for the @emacsclient@.
--
-- Note that this uses the @-F@ option to set the
-- <https://www.gnu.org/software/emacs/manual/html_node/emacs/Frame-Parameters.html frame parameters>
-- alist, which the @emacs@ executable does not support.
setFrameName :: String -> X Input
setFrameName :: String -> X Input
setFrameName String
n = Input -> X Input
forall a. a -> X a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((String
" -F '(quote (name . \"" String -> Input
forall a. Semigroup a => a -> a -> a
<> String
n String -> Input
forall a. Semigroup a => a -> a -> a
<> String
"\"))' ") String -> Input
forall a. Semigroup a => a -> a -> a
<>)

-- | Set the appropriate X class for a window.  This will more often
-- than not actually be the
-- <https://tronche.com/gui/x/icccm/sec-4.html#WM_CLASS instance name>.
setXClass :: String -> X Input
setXClass :: String -> X Input
setXClass = Input -> X Input
forall a. a -> X a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Input -> X Input) -> (String -> Input) -> String -> X Input
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Input
mkDList (String -> Input) -> Input -> String -> Input
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
" --class " String -> Input
forall a. Semigroup a => a -> a -> a
<>)

-- | Spawn the 'XMonad.Core.XConfig.terminal' in some directory; it must
-- support the @--working-directory@ option.
termInDir :: X Input
termInDir :: X Input
termInDir = X Input
inTerm X Input -> X Input -> X Input
>-> X Input
inWorkingDir

-----------------------------------------------------------------------
-- Emacs

-- | Transform the given input into an elisp function; i.e., surround it
-- with parentheses.
--
-- >>> elispFun "arxiv-citation URL"
-- " '( arxiv-citation URL )' "
elispFun :: String -> String
elispFun :: Input
elispFun String
f = String
" '( " String -> Input
forall a. Semigroup a => a -> a -> a
<> String
f String -> Input
forall a. Semigroup a => a -> a -> a
<> String
" )' "

-- | Treat an argument as a string; i.e., wrap it with quotes.
--
-- >>> asString "string"
-- " \"string\" "
asString :: String -> String
asString :: Input
asString String
s = String
" \"" String -> Input
forall a. Semigroup a => a -> a -> a
<> String
s String -> Input
forall a. Semigroup a => a -> a -> a
<> String
"\" "

-- | Wrap the given commands in a @progn@.  The given commands need not
-- be wrapped in parentheses (but can); this will be done by the
-- function.  For example:
--
-- >>> progn [require "this-lib", "function-from-this-lib arg", "(other-function arg2)"]
-- "(progn (require (quote this-lib)) (function-from-this-lib arg) (other-function arg2))"
progn :: [String] -> String
progn :: [String] -> String
progn = Input
inParens Input -> ([String] -> String) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"progn " String -> Input
forall a. Semigroup a => a -> a -> a
<>) Input -> ([String] -> String) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unwords ([String] -> String)
-> ([String] -> [String]) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Input -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Input
inParens

-- | Require a package.
--
-- >>> require "arxiv-citation"
-- "(require (quote arxiv-citation))"
require :: String -> String
require :: Input
require = Input
inParens Input -> Input -> Input
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"require " String -> Input
forall a. Semigroup a => a -> a -> a
<>) Input -> Input -> Input
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Input
quote

-- | Quote a symbol.
--
-- >>> quote "new-process"
-- "(quote new-process)"
quote :: String -> String
quote :: Input
quote = Input
inParens Input -> Input -> Input
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"quote " String -> Input
forall a. Semigroup a => a -> a -> a
<>)

-- | Call @find-file@.
--
-- >>> findFile "/path/to/file"
-- "(find-file \"/path/to/file\" )"
findFile :: String -> String
findFile :: Input
findFile = Input
inParens Input -> Input -> Input
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"find-file" String -> Input
forall a. Semigroup a => a -> a -> a
<>) Input -> Input -> Input
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Input
asString

-- | Make a list of the given inputs.
--
-- >>> list ["foo", "bar", "baz", "qux"]
-- "(list foo bar baz qux)"
list :: [String] -> String
list :: [String] -> String
list = Input
inParens Input -> ([String] -> String) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"list " String -> Input
forall a. Semigroup a => a -> a -> a
<>) Input -> ([String] -> String) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unwords

-- | Like 'progn', but with @save-excursion@.
--
-- >>> saveExcursion [require "this-lib", "function-from-this-lib arg", "(other-function arg2)"]
-- "(save-excursion (require (quote this-lib)) (function-from-this-lib arg) (other-function arg2))"
saveExcursion :: [String] -> String
saveExcursion :: [String] -> String
saveExcursion = Input
inParens Input -> ([String] -> String) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"save-excursion " String -> Input
forall a. Semigroup a => a -> a -> a
<>) Input -> ([String] -> String) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unwords ([String] -> String)
-> ([String] -> [String]) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Input -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Input
inParens

-----------------------------------------------------------------------
-- Batch mode

-- | Tell Emacs to enable batch-mode.
asBatch :: X Input
asBatch :: X Input
asBatch = Input -> X Input
forall a. a -> X a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
" --batch " String -> Input
forall a. Semigroup a => a -> a -> a
<>)

-- | An Emacs library.
data EmacsLib
  = OwnFile !String
    -- ^ A /file/ from 'emacsLispDir'.
  | ElpaLib !String
    -- ^ A /directory/ in 'emacsElpaDir'.
  | Special !String
    -- ^ Special /files/; these will not be looked up somewhere, but
    -- forwarded verbatim (as a path).

-- | Load some Emacs libraries.  This is useful when executing scripts
-- in batch mode.
withEmacsLibs :: [EmacsLib] -> X Input
withEmacsLibs :: [EmacsLib] -> X Input
withEmacsLibs [EmacsLib]
libs = (ProcessConfig -> X Input) -> X Input
forall (m :: * -> *) a b.
(MonadReader XConf m, Typeable a, Default a) =>
(a -> m b) -> m b
XC.withDef ((ProcessConfig -> X Input) -> X Input)
-> (ProcessConfig -> X Input) -> X Input
forall a b. (a -> b) -> a -> b
$ \ProcessConfig{String
emacsLispDir :: ProcessConfig -> String
emacsLispDir :: String
emacsLispDir, String
emacsElpaDir :: ProcessConfig -> String
emacsElpaDir :: String
emacsElpaDir} -> do
  String
lispDir <- String -> X String
forall (m :: * -> *). MonadIO m => String -> m String
mkAbsolutePath String
emacsLispDir
  String
elpaDir <- String -> X String
forall (m :: * -> *). MonadIO m => String -> m String
mkAbsolutePath String
emacsElpaDir
  [String]
lisp    <- IO [String] -> X [String]
forall a. IO a -> X a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [String] -> X [String]) -> IO [String] -> X [String]
forall a b. (a -> b) -> a -> b
$ String -> IO [String]
getDirectoryContents String
lispDir
  [String]
elpa    <- IO [String] -> X [String]
forall a. IO a -> X a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [String] -> X [String]) -> IO [String] -> X [String]
forall a b. (a -> b) -> a -> b
$ String -> IO [String]
getDirectoryContents String
elpaDir

  let EmacsLib -> Maybe String
getLib :: EmacsLib -> Maybe String = \case
        OwnFile String
f -> ((String
"-l " String -> Input
forall a. Semigroup a => a -> a -> a
<> String
lispDir) String -> Input
forall a. Semigroup a => a -> a -> a
<>) Input -> Maybe String -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> Bool) -> [String] -> Maybe String
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (String
f          String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) [String]
lisp
        ElpaLib String
d -> ((String
"-L " String -> Input
forall a. Semigroup a => a -> a -> a
<> String
elpaDir) String -> Input
forall a. Semigroup a => a -> a -> a
<>) Input -> Maybe String -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> Bool) -> [String] -> Maybe String
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((String
d String -> Input
forall a. Semigroup a => a -> a -> a
<> String
"-") String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) [String]
elpa
        Special String
f -> String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String
" -l " String -> Input
forall a. Semigroup a => a -> a -> a
<> String
f
  Input -> X Input
forall a. a -> X a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Input -> X Input)
-> ([EmacsLib] -> Input) -> [EmacsLib] -> X Input
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Input
mkDList (String -> Input) -> ([EmacsLib] -> String) -> [EmacsLib] -> Input
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unwords ([String] -> String)
-> ([EmacsLib] -> [String]) -> [EmacsLib] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EmacsLib -> Maybe String) -> [EmacsLib] -> [String]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe EmacsLib -> Maybe String
getLib ([EmacsLib] -> X Input) -> [EmacsLib] -> X Input
forall a b. (a -> b) -> a -> b
$ [EmacsLib]
libs

-----------------------------------------------------------------------
-- Util

mkDList :: String -> ShowS
mkDList :: String -> Input
mkDList = String -> Input
forall a. Semigroup a => a -> a -> a
(<>) (String -> Input) -> Input -> String -> Input
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Input
forall a. Semigroup a => a -> a -> a
<> String
" ")

inParens :: String -> String
inParens :: Input
inParens String
s = case String
s of
  Char
'(' : String
_ -> String
s
  String
_       -> String
"(" String -> Input
forall a. Semigroup a => a -> a -> a
<> String
s String -> Input
forall a. Semigroup a => a -> a -> a
<> String
")"

tryQuote :: String -> String
tryQuote :: Input
tryQuote String
s = case (Char -> Bool) -> Input
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') String
s of
  Char
'\'' : String
_ -> String
s
  String
_        -> String
"'" String -> Input
forall a. Semigroup a => a -> a -> a
<> String
s String -> Input
forall a. Semigroup a => a -> a -> a
<> String
"'"