CreateProcess.hs

{-# LANGUAGE NoImplicitPrelude #-}
{-# OPTIONS_GHC -Wall #-}

module Control.Process.CreateProcess
  ( CreateProcess,
    GetCreateProcess (..),
    HasCreateProcess (..),
    ReviewCreateProcess (..),
    AsCreateProcess (..),
    streams,
    streams1,
  )
where

import Control.Applicative (Applicative ((<*>)))
import Control.Category (id, (.))
import Control.Lens
  ( Field1 (_1),
    Field2 (_2),
    Getter,
    Lens',
    Prism',
    Review,
    Traversable (traverse),
    Traversal',
    Traversal1',
    only,
    unto,
    _Just,
  )
import Control.Process.UserID (HasUserID (userIDWord32))
import Data.Bool (Bool (True))
import Data.Functor (Functor (fmap), (<$>))
import Data.Functor.Apply (Apply ((<.>)))
import Data.Maybe (Maybe (..))
import Data.String (String)
import Data.Word (Word32)
import System.FilePath (FilePath)
import System.Process (CreateProcess, StdStream (..))
import qualified System.Process as Process (CreateProcess (..))
import System.Process.Internals (GroupID, UserID)

-- $setup
-- >>> import Prelude
-- >>> import Control.Lens
-- >>> import System.Process (proc, shell)

-- | Type class for values that can be viewed as a @CreateProcess@.
--
-- >>> view getCreateProcess (proc "echo" ["hello"]) == proc "echo" ["hello"]
-- True
class GetCreateProcess a where
  getCreateProcess ::
    Getter a CreateProcess

-- |
--
-- >>> view getCreateProcess (proc "echo" ["hello"]) == proc "echo" ["hello"]
-- True
instance GetCreateProcess CreateProcess where
  getCreateProcess = id
  {-# INLINE getCreateProcess #-}

-- | Type class for values with a lens into a @CreateProcess@.
--
-- >>> view close_fds (proc "echo" ["hello"])
-- False
class (GetCreateProcess a) => HasCreateProcess a where
  create_process ::
    Lens' a CreateProcess
  {-# INLINE child_group #-}
  child_group ::
    Lens' a (Maybe GroupID)
  child_group =
    create_process . child_group
  {-# INLINE child_user #-}
  child_user ::
    Lens' a (Maybe UserID)
  child_user =
    create_process . child_user
  {-# INLINE close_fds #-}
  close_fds ::
    Lens' a Bool
  close_fds =
    create_process . close_fds
  {-# INLINE create_group #-}
  create_group ::
    Lens' a Bool
  create_group =
    create_process . create_group
  {-# INLINE create_new_console #-}
  create_new_console ::
    Lens' a Bool
  create_new_console =
    create_process . create_new_console
  {-# INLINE cwd #-}
  cwd ::
    Lens' a (Maybe FilePath)
  cwd =
    create_process . cwd
  {-# INLINE delegate_ctlc #-}
  delegate_ctlc ::
    Lens' a Bool
  delegate_ctlc =
    create_process . delegate_ctlc
  {-# INLINE detach_console #-}
  detach_console ::
    Lens' a Bool
  detach_console =
    create_process . detach_console
  {-# INLINE env #-}
  env ::
    Lens' a (Maybe [(String, String)])
  env =
    create_process . env
  {-# INLINE new_session #-}
  new_session ::
    Lens' a Bool
  new_session =
    create_process . new_session
  {-# INLINE std_err #-}
  std_err ::
    Lens' a StdStream
  std_err =
    create_process . std_err
  {-# INLINE std_in #-}
  std_in ::
    Lens' a StdStream
  std_in =
    create_process . std_in
  {-# INLINE std_out #-}
  std_out ::
    Lens' a StdStream
  std_out =
    create_process . std_out
  {-# INLINE use_process_jobs #-}
  use_process_jobs ::
    Lens' a Bool
  use_process_jobs =
    create_process . use_process_jobs

  {-# INLINE cwd' #-}
  cwd' ::
    Traversal' a FilePath
  cwd' =
    cwd . _Just
  {-# INLINE envList #-}
  envList ::
    Traversal' a [(String, String)]
  envList =
    env . _Just
  {-# INLINE envElement #-}
  envElement ::
    Traversal' a (String, String)
  envElement =
    envList . traverse
  {-# INLINE envElementKey #-}
  envElementKey ::
    Traversal' a String
  envElementKey =
    envElement . _1
  {-# INLINE envElementValue #-}
  envElementValue ::
    Traversal' a String
  envElementValue =
    envElement . _2
  {-# INLINE close_fds' #-}
  close_fds' ::
    Traversal' a ()
  close_fds' =
    close_fds . only True
  {-# INLINE create_group' #-}
  create_group' ::
    Traversal' a ()
  create_group' =
    create_group . only True
  {-# INLINE delegate_ctlc' #-}
  delegate_ctlc' ::
    Traversal' a ()
  delegate_ctlc' =
    delegate_ctlc . only True
  {-# INLINE detach_console' #-}
  detach_console' ::
    Traversal' a ()
  detach_console' =
    detach_console . only True
  {-# INLINE create_new_console' #-}
  create_new_console' ::
    Traversal' a ()
  create_new_console' =
    create_new_console . only True
  {-# INLINE new_session' #-}
  new_session' ::
    Traversal' a ()
  new_session' =
    new_session . only True
  {-# INLINE child_group' #-}
  child_group' ::
    Traversal' a GroupID
  child_group' =
    child_group . _Just
  {-# INLINE child_user' #-}
  child_user' ::
    Traversal' a UserID
  child_user' =
    child_user . _Just
  {-# INLINE child_user'' #-}
  child_user'' ::
    Traversal' a Word32
  child_user'' =
    child_user' . userIDWord32
  {-# INLINE use_process_jobs' #-}
  use_process_jobs' ::
    Traversal' a ()
  use_process_jobs' =
    use_process_jobs . only True

-- |
--
-- >>> view close_fds (proc "echo" ["hello"])
-- False
-- >>> view (std_in) (proc "echo" ["hello"])
-- Inherit
-- >>> view cwd (proc "echo" ["hello"])
-- Nothing
instance HasCreateProcess CreateProcess where
  create_process =
    id
  child_group f p =
    fmap (\x -> p {Process.child_group = x}) (f (Process.child_group p))
  child_user f p =
    fmap (\x -> p {Process.child_user = x}) (f (Process.child_user p))
  close_fds f p =
    fmap (\x -> p {Process.close_fds = x}) (f (Process.close_fds p))
  create_group f p =
    fmap (\x -> p {Process.create_group = x}) (f (Process.create_group p))
  create_new_console f p =
    fmap (\x -> p {Process.create_new_console = x}) (f (Process.create_new_console p))
  cwd f p =
    fmap (\x -> p {Process.cwd = x}) (f (Process.cwd p))
  delegate_ctlc f p =
    fmap (\x -> p {Process.delegate_ctlc = x}) (f (Process.delegate_ctlc p))
  detach_console f p =
    fmap (\x -> p {Process.detach_console = x}) (f (Process.detach_console p))
  env f p =
    fmap (\x -> p {Process.env = x}) (f (Process.env p))
  new_session f p =
    fmap (\x -> p {Process.new_session = x}) (f (Process.new_session p))
  std_err f p =
    fmap (\x -> p {Process.std_err = x}) (f (Process.std_err p))
  std_in f p =
    fmap (\x -> p {Process.std_in = x}) (f (Process.std_in p))
  std_out f p =
    fmap (\x -> p {Process.std_out = x}) (f (Process.std_out p))
  use_process_jobs f p =
    fmap (\x -> p {Process.use_process_jobs = x}) (f (Process.use_process_jobs p))

-- | Type class for values that can be constructed from a @CreateProcess@.
--
-- >>> review reviewCreateProcess (proc "echo" ["hi"]) == proc "echo" ["hi"]
-- True
class ReviewCreateProcess a where
  reviewCreateProcess ::
    Review a CreateProcess

-- |
--
-- >>> review reviewCreateProcess (proc "echo" ["hi"]) == proc "echo" ["hi"]
-- True
instance ReviewCreateProcess CreateProcess where
  reviewCreateProcess = unto id
  {-# INLINE reviewCreateProcess #-}

-- | Type class for values with a prism into a @CreateProcess@.
--
-- >>> preview _CreateProcess (proc "echo" ["hi"]) == Just (proc "echo" ["hi"])
-- True
class (ReviewCreateProcess a) => AsCreateProcess a where
  _CreateProcess ::
    Prism' a CreateProcess

-- |
--
-- >>> preview _CreateProcess (proc "echo" ["hi"]) == Just (proc "echo" ["hi"])
-- True
instance AsCreateProcess CreateProcess where
  _CreateProcess =
    id

-- |
--
-- >>> toListOf streams (proc "echo" ["hi"])
-- [Inherit,Inherit,Inherit]
-- >>> set streams CreatePipe (proc "echo" ["hi"]) ^. std_in
-- CreatePipe
streams ::
  Traversal' CreateProcess StdStream
streams f p =
  (\sti' sto' ste' -> p {Process.std_in = sti', Process.std_out = sto', Process.std_err = ste'})
    <$> f (Process.std_in p)
    <*> f (Process.std_out p)
    <*> f (Process.std_err p)

-- |
--
-- >>> toListOf streams1 (proc "echo" ["hi"])
-- [Inherit,Inherit,Inherit]
streams1 ::
  Traversal1' CreateProcess StdStream
streams1 f p =
  (\sti' sto' ste' -> p {Process.std_in = sti', Process.std_out = sto', Process.std_err = ste'})
    <$> f (Process.std_in p)
    <.> f (Process.std_out p)
    <.> f (Process.std_err p)