{-# options_haddock prune #-}

-- |Description: Pty Interpreters, Internal
module Polysemy.Process.Interpreter.Pty where

import Polysemy.Conc.Effect.Scoped (Scoped)
import Polysemy.Conc.Interpreter.Scoped (interpretScopedResumable)
import Polysemy.Resume (Stop, stopEitherWith, stopNote, type (!!))
import System.Posix (closeFd, fdToHandle, openPseudoTerminal)
import System.Posix.Pty (closePty, createPty, ptyDimensions, resizePty)

import Polysemy.Process.Data.PtyError (PtyError (PtyError))
import Polysemy.Process.Data.PtyResources (PtyResources (PtyResources, handle, primary, pty, secondary))
import Polysemy.Process.Effect.Pty (Cols (Cols), Pty (Handle, Resize, Size), Rows (Rows))

tryStop ::
  Members [Stop PtyError, Embed IO] r =>
  IO a ->
  Sem r a
tryStop :: forall (r :: [(* -> *) -> * -> *]) a.
Members '[Stop PtyError, Embed IO] r =>
IO a -> Sem r a
tryStop =
  (Text -> PtyError) -> Either Text a -> Sem r a
forall err' (r :: [(* -> *) -> * -> *]) err a.
Member (Stop err') r =>
(err -> err') -> Either err a -> Sem r a
stopEitherWith Text -> PtyError
PtyError (Either Text a -> Sem r a)
-> (IO a -> Sem r (Either Text a)) -> IO a -> Sem r a
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< IO a -> Sem r (Either Text a)
forall (r :: [(* -> *) -> * -> *]) a.
Member (Embed IO) r =>
IO a -> Sem r (Either Text a)
tryAny

acquirePty ::
  Member (Embed IO) r =>
  Sem (Stop PtyError : r) PtyResources
acquirePty :: forall (r :: [(* -> *) -> * -> *]).
Member (Embed IO) r =>
Sem (Stop PtyError : r) PtyResources
acquirePty = do
  (Fd
primary, Fd
secondary) <- IO (Fd, Fd) -> Sem (Stop PtyError : r) (Fd, Fd)
forall (r :: [(* -> *) -> * -> *]) a.
Members '[Stop PtyError, Embed IO] r =>
IO a -> Sem r a
tryStop IO (Fd, Fd)
openPseudoTerminal
  Pty
pty <- PtyError -> Maybe Pty -> Sem (Stop PtyError : r) Pty
forall err (r :: [(* -> *) -> * -> *]) a.
Member (Stop err) r =>
err -> Maybe a -> Sem r a
stopNote (Text -> PtyError
PtyError Text
"no pty returned") (Maybe Pty -> Sem (Stop PtyError : r) Pty)
-> Sem (Stop PtyError : r) (Maybe Pty)
-> Sem (Stop PtyError : r) Pty
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Maybe Pty) -> Sem (Stop PtyError : r) (Maybe Pty)
forall (r :: [(* -> *) -> * -> *]) a.
Members '[Stop PtyError, Embed IO] r =>
IO a -> Sem r a
tryStop (Fd -> IO (Maybe Pty)
createPty Fd
secondary)
  Handle
handle <- IO Handle -> Sem (Stop PtyError : r) Handle
forall (r :: [(* -> *) -> * -> *]) a.
Members '[Stop PtyError, Embed IO] r =>
IO a -> Sem r a
tryStop (Fd -> IO Handle
fdToHandle Fd
secondary)
  pure PtyResources :: Fd -> Fd -> Handle -> Pty -> PtyResources
PtyResources {Handle
Fd
Pty
handle :: Handle
pty :: Pty
secondary :: Fd
primary :: Fd
$sel:secondary:PtyResources :: Fd
$sel:pty:PtyResources :: Pty
$sel:primary:PtyResources :: Fd
$sel:handle:PtyResources :: Handle
..}

releasePty ::
  Member (Embed IO) r =>
  PtyResources ->
  Sem r ()
releasePty :: forall (r :: [(* -> *) -> * -> *]).
Member (Embed IO) r =>
PtyResources -> Sem r ()
releasePty PtyResources {Fd
primary :: Fd
$sel:primary:PtyResources :: PtyResources -> Fd
primary, Pty
pty :: Pty
$sel:pty:PtyResources :: PtyResources -> Pty
pty} = do
  IO () -> Sem r ()
forall (r :: [(* -> *) -> * -> *]).
Member (Embed IO) r =>
IO () -> Sem r ()
tryAny_ (Pty -> IO ()
closePty Pty
pty)
  IO () -> Sem r ()
forall (r :: [(* -> *) -> * -> *]).
Member (Embed IO) r =>
IO () -> Sem r ()
tryAny_ (Fd -> IO ()
closeFd Fd
primary)

withPty ::
  Members [Resource, Embed IO] r =>
  (PtyResources -> Sem (Stop PtyError : r) a) ->
  Sem (Stop PtyError : r) a
withPty :: forall (r :: [(* -> *) -> * -> *]) a.
Members '[Resource, Embed IO] r =>
(PtyResources -> Sem (Stop PtyError : r) a)
-> Sem (Stop PtyError : r) a
withPty =
  Sem (Stop PtyError : r) PtyResources
-> (PtyResources -> Sem (Stop PtyError : r) ())
-> (PtyResources -> Sem (Stop PtyError : r) a)
-> Sem (Stop PtyError : r) a
forall (r :: [(* -> *) -> * -> *]) a c b.
MemberWithError Resource r =>
Sem r a -> (a -> Sem r c) -> (a -> Sem r b) -> Sem r b
bracket Sem (Stop PtyError : r) PtyResources
forall (r :: [(* -> *) -> * -> *]).
Member (Embed IO) r =>
Sem (Stop PtyError : r) PtyResources
acquirePty PtyResources -> Sem (Stop PtyError : r) ()
forall (r :: [(* -> *) -> * -> *]).
Member (Embed IO) r =>
PtyResources -> Sem r ()
releasePty

-- |Interpret Pty as a 'System.Posix.Pty'.
interpretPty ::
  Members [Resource, Embed IO] r =>
  InterpreterFor (Scoped PtyResources Pty !! PtyError) r
interpretPty :: forall (r :: [(* -> *) -> * -> *]).
Members '[Resource, Embed IO] r =>
InterpreterFor (Scoped PtyResources Pty !! PtyError) r
interpretPty =
  (forall x.
 (PtyResources -> Sem (Stop PtyError : r) x)
 -> Sem (Stop PtyError : r) x)
-> (forall (r0 :: [(* -> *) -> * -> *]) x.
    PtyResources -> Pty (Sem r0) x -> Sem (Stop PtyError : r) x)
-> InterpreterFor (Scoped PtyResources Pty !! PtyError) r
forall resource (effect :: (* -> *) -> * -> *) err
       (r :: [(* -> *) -> * -> *]).
(forall x.
 (resource -> Sem (Stop err : r) x) -> Sem (Stop err : r) x)
-> (forall (r0 :: [(* -> *) -> * -> *]) x.
    resource -> effect (Sem r0) x -> Sem (Stop err : r) x)
-> InterpreterFor (Scoped resource effect !! err) r
interpretScopedResumable forall (r :: [(* -> *) -> * -> *]) a.
Members '[Resource, Embed IO] r =>
(PtyResources -> Sem (Stop PtyError : r) a)
-> Sem (Stop PtyError : r) a
forall x.
(PtyResources -> Sem (Stop PtyError : r) x)
-> Sem (Stop PtyError : r) x
withPty \ PtyResources {Handle
Fd
Pty
pty :: Pty
handle :: Handle
secondary :: Fd
primary :: Fd
$sel:secondary:PtyResources :: PtyResources -> Fd
$sel:pty:PtyResources :: PtyResources -> Pty
$sel:primary:PtyResources :: PtyResources -> Fd
$sel:handle:PtyResources :: PtyResources -> Handle
..} -> \case
    Pty (Sem r0) x
Handle ->
      Handle -> Sem (Stop PtyError : r) Handle
forall (f :: * -> *) a. Applicative f => a -> f a
pure Handle
handle
    Resize Rows
rows Cols
cols -> do
      IO () -> Sem (Stop PtyError : r) ()
forall (r :: [(* -> *) -> * -> *]) a.
Members '[Stop PtyError, Embed IO] r =>
IO a -> Sem r a
tryStop (Pty -> (Int, Int) -> IO ()
resizePty Pty
pty (Rows -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Rows
rows, Cols -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Cols
cols))
    Pty (Sem r0) x
Size ->
      (Int -> Rows) -> (Int -> Cols) -> (Int, Int) -> (Rows, Cols)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap Int -> Rows
Rows Int -> Cols
Cols ((Int, Int) -> (Rows, Cols))
-> Sem (Stop PtyError : r) (Int, Int)
-> Sem (Stop PtyError : r) (Rows, Cols)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Int, Int) -> Sem (Stop PtyError : r) (Int, Int)
forall (r :: [(* -> *) -> * -> *]) a.
Members '[Stop PtyError, Embed IO] r =>
IO a -> Sem r a
tryStop (Pty -> IO (Int, Int)
ptyDimensions Pty
pty)