CmdSpec.hs

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

module Control.Process.CmdSpec
  ( CmdSpec (..),
    GetCmdSpec (..),
    HasCmdSpec (..),
    ReviewCmdSpec (..),
    AsCmdSpec (..),
  )
where

import Control.Category (id, (.))
import Control.Lens
  ( Field1 (_1),
    Field2 (_2),
    Getter,
    Lens',
    Prism',
    Review,
    Traversable (traverse),
    Traversal',
    prism',
    to,
    unto,
  )
import Data.Functor (Functor (fmap))
import Data.Maybe (Maybe (Just, Nothing))
import Data.String (String)
import Data.Tuple (uncurry)
import System.FilePath (FilePath)
import System.Process (CmdSpec (..), CreateProcess)
import qualified System.Process as Process (CreateProcess (..))

-- $setup
-- >>> import Prelude
-- >>> import Control.Lens

-- | Type class for values that can be viewed as a @CmdSpec@.
--
-- >>> view getCmdSpec (ShellCommand "ls -la")
-- ShellCommand "ls -la"
class GetCmdSpec a where
  getCmdSpec ::
    Getter a CmdSpec

-- |
--
-- >>> view getCmdSpec (ShellCommand "ls -la")
-- ShellCommand "ls -la"
instance GetCmdSpec CmdSpec where
  getCmdSpec = id
  {-# INLINE getCmdSpec #-}

-- |
--
-- >>> import System.Process (proc)
-- >>> view getCmdSpec (proc "echo" ["hello"])
-- RawCommand "echo" ["hello"]
instance GetCmdSpec CreateProcess where
  getCmdSpec = to Process.cmdspec
  {-# INLINE getCmdSpec #-}

-- | Type class for values with a lens into a @CmdSpec@.
--
-- >>> view cmdSpec (ShellCommand "ls -la")
-- ShellCommand "ls -la"
class (GetCmdSpec a) => HasCmdSpec a where
  cmdSpec ::
    Lens' a CmdSpec
  {-# INLINE shellCommand #-}
  shellCommand ::
    Traversal' a String
  shellCommand =
    cmdSpec . _ShellCommand
  {-# INLINE rawCommand #-}
  rawCommand ::
    Traversal' a (FilePath, [String])
  rawCommand =
    cmdSpec . _RawCommand
  {-# INLINE rawCommandExe #-}
  rawCommandExe ::
    Traversal' a FilePath
  rawCommandExe =
    rawCommand . _1
  {-# INLINE rawCommandArgumentList #-}
  rawCommandArgumentList ::
    Traversal' a [String]
  rawCommandArgumentList =
    rawCommand . _2
  {-# INLINE rawCommandArguments #-}
  rawCommandArguments ::
    Traversal' a String
  rawCommandArguments =
    rawCommandArgumentList . traverse

-- |
--
-- >>> view cmdSpec (ShellCommand "ls")
-- ShellCommand "ls"
-- >>> set cmdSpec (RawCommand "echo" ["hi"]) (ShellCommand "ls")
-- RawCommand "echo" ["hi"]
instance HasCmdSpec CmdSpec where
  cmdSpec =
    id

-- |
--
-- >>> import System.Process (proc)
-- >>> view cmdSpec (proc "echo" ["hello"])
-- RawCommand "echo" ["hello"]
instance HasCmdSpec CreateProcess where
  cmdSpec f p =
    fmap (\x -> p {Process.cmdspec = x}) (f (Process.cmdspec p))

-- | Type class for values that can be constructed from a @CmdSpec@.
--
-- >>> review reviewCmdSpec (ShellCommand "ls") :: CmdSpec
-- ShellCommand "ls"
class ReviewCmdSpec a where
  reviewCmdSpec ::
    Review a CmdSpec

-- |
--
-- >>> review reviewCmdSpec (ShellCommand "ls") :: CmdSpec
-- ShellCommand "ls"
instance ReviewCmdSpec CmdSpec where
  reviewCmdSpec = unto id
  {-# INLINE reviewCmdSpec #-}

-- | Type class for values with a prism into a @CmdSpec@.
--
-- >>> preview _CmdSpec (ShellCommand "ls -la")
-- Just (ShellCommand "ls -la")
class (ReviewCmdSpec a) => AsCmdSpec a where
  _CmdSpec ::
    Prism' a CmdSpec
  {-# INLINE _ShellCommand #-}
  _ShellCommand ::
    Prism' a String
  _ShellCommand =
    _CmdSpec . _ShellCommand
  {-# INLINE _RawCommand #-}
  _RawCommand ::
    Prism' a (FilePath, [String])
  _RawCommand =
    _CmdSpec . _RawCommand
  {-# INLINE _RawCommandExe #-}
  _RawCommandExe ::
    Traversal' a FilePath
  _RawCommandExe =
    _RawCommand . _1
  {-# INLINE _RawCommandArgumentList #-}
  _RawCommandArgumentList ::
    Traversal' a [String]
  _RawCommandArgumentList =
    _RawCommand . _2
  {-# INLINE _RawCommandArguments #-}
  _RawCommandArguments ::
    Traversal' a String
  _RawCommandArguments =
    _RawCommandArgumentList . traverse

-- |
--
-- >>> preview _ShellCommand (ShellCommand "ls -la")
-- Just "ls -la"
-- >>> preview _ShellCommand (RawCommand "ls" ["-la"])
-- Nothing
-- >>> preview _RawCommand (RawCommand "ls" ["-la"])
-- Just ("ls",["-la"])
-- >>> preview _RawCommand (ShellCommand "ls -la")
-- Nothing
-- >>> review _ShellCommand "echo hello" :: CmdSpec
-- ShellCommand "echo hello"
-- >>> review _RawCommand ("/bin/ls", ["-la"]) :: CmdSpec
-- RawCommand "/bin/ls" ["-la"]
instance AsCmdSpec CmdSpec where
  _CmdSpec = id
  _ShellCommand =
    prism'
      ShellCommand
      ( \case
          ShellCommand a -> Just a
          _ -> Nothing
      )
  _RawCommand =
    prism'
      (uncurry RawCommand)
      ( \case
          RawCommand a b -> Just (a, b)
          _ -> Nothing
      )