{-# LANGUAGE CPP #-}
{-# LANGUAGE NoImplicitPrelude #-}

{- ORMOLU_DISABLE -}

-- | Provides the 'MonadTerminal' typeclass.
--
-- @since 0.1
module Effects.System.Terminal
  ( -- * Effect
    MonadTerminal (..),

    -- * Functions
    print,

    -- ** Text
    putText,
    putTextLn,
    getTextLine,

#if MIN_VERSION_base(4,15,0)
    getTextContents',
#endif

    -- ** Window
    getTerminalWidth,
    getTerminalHeight,

    -- * Reexports
    Natural,
    Window (..),
    Text,
  )
where

{- ORMOLU_ENABLE -}

import Control.Monad.Catch (MonadThrow (throwM))
import Control.Monad.Trans.Class (MonadTrans (lift))
import Control.Monad.Trans.Reader (ReaderT)
import Data.ByteString (ByteString)
import Data.ByteString qualified as BS
import Data.Text (Text)
import Data.Text qualified as T
import GHC.IO.Exception
  ( IOErrorType (SystemError),
    IOException
      ( IOError,
        ioe_description,
        ioe_errno,
        ioe_filename,
        ioe_handle,
        ioe_location,
        ioe_type
      ),
  )
import GHC.Natural (Natural)
import GHC.Stack (HasCallStack)
import System.Console.Pretty qualified as CPretty
import System.Console.Terminal.Size (Window (Window, height, width), size)
import System.IO qualified as IO
import Prelude
  ( Applicative (pure),
    Bool,
    Char,
    IO,
    Integral,
    Maybe (Just, Nothing),
    Monad ((>>=)),
    Show (show),
    String,
    ($),
    (.),
    (<$>),
    (<>),
  )

-- Explicit prelude because of IO clashes.

{- ORMOLU_DISABLE -}

-- | Represents a terminal.
--
-- @since 0.1
class Monad m => MonadTerminal m where
  -- | Lifted 'IO.putStr'.
  --
  -- @since 0.1
  putStr :: HasCallStack => String -> m ()

  -- | Lifted 'IO.putStrLn'.
  --
  -- @since 0.1
  putStrLn :: HasCallStack => String -> m ()
  putStrLn = String -> m ()
forall (m :: * -> *).
(MonadTerminal m, HasCallStack) =>
String -> m ()
putStr (String -> m ()) -> (String -> String) -> String -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n")
  {-# INLINEABLE putStrLn #-}

  -- | Lifted 'BS.putStr'.
  --
  -- @since 0.1
  putBinary :: HasCallStack => ByteString -> m ()

  -- | Lifted 'IO.getChar'.
  --
  -- @since 0.1
  getChar :: HasCallStack => m Char

  -- | Lifted 'IO.getLine'.
  --
  -- @since 0.1
  getLine :: HasCallStack => m String

#if MIN_VERSION_base(4,15,0)
  -- | Lifted 'IO.getContents''.
  --
  -- @since 0.1
  getContents' :: HasCallStack => m String
#endif

  -- | Retrieves the terminal size.
  --
  -- @since 0.1
  getTerminalSize :: (HasCallStack, Integral a) => m (Window a)

  -- | Lifted 'CPretty.supportsPretty'.
  --
  -- @since 0.1
  supportsPretty :: HasCallStack => m Bool

#if MIN_VERSION_base(4,15,0)
  {-# MINIMAL putStr, putBinary, getChar, getLine, getContents', getTerminalSize, supportsPretty #-}
#else
  {-# MINIMAL putStr , putBinary, getChar, getLine, getTerminalSize, supportsPretty #-}
#endif

-- | @since 0.1
instance MonadTerminal IO where
  putStr :: HasCallStack => String -> IO ()
putStr = String -> IO ()
IO.putStr
  {-# INLINEABLE putStr #-}
  putStrLn :: HasCallStack => String -> IO ()
putStrLn = String -> IO ()
IO.putStrLn
  {-# INLINEABLE putStrLn #-}
  putBinary :: HasCallStack => ByteString -> IO ()
putBinary = ByteString -> IO ()
BS.putStr
  {-# INLINEABLE putBinary #-}
  getChar :: HasCallStack => IO Char
getChar = IO Char
IO.getChar
  {-# INLINEABLE getChar #-}
  getLine :: HasCallStack => IO String
getLine = IO String
IO.getLine
  {-# INLINEABLE getLine #-}
#if MIN_VERSION_base(4,15,0)
  getContents' :: HasCallStack => IO String
getContents' = IO String
IO.getContents'
  {-# INLINEABLE getContents' #-}
#endif
  getTerminalSize :: forall a. (HasCallStack, Integral a) => IO (Window a)
getTerminalSize =
    IO (Maybe (Window a))
forall n. Integral n => IO (Maybe (Window n))
size IO (Maybe (Window a))
-> (Maybe (Window a) -> IO (Window a)) -> IO (Window a)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Just Window a
h -> Window a -> IO (Window a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Window a
h
      Maybe (Window a)
Nothing -> IOException -> IO (Window a)
forall e a. (HasCallStack, Exception e) => e -> IO a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (IOException -> IO (Window a)) -> IOException -> IO (Window a)
forall a b. (a -> b) -> a -> b
$
        IOError
          { ioe_handle :: Maybe Handle
ioe_handle = Maybe Handle
forall a. Maybe a
Nothing,
            ioe_type :: IOErrorType
ioe_type = IOErrorType
SystemError,
            ioe_location :: String
ioe_location = String
"getTerminalSize",
            ioe_description :: String
ioe_description = String
"Failed to detect the terminal size",
            ioe_errno :: Maybe CInt
ioe_errno = Maybe CInt
forall a. Maybe a
Nothing,
            ioe_filename :: Maybe String
ioe_filename = Maybe String
forall a. Maybe a
Nothing
          }
  {-# INLINEABLE getTerminalSize #-}

  supportsPretty :: HasCallStack => IO Bool
supportsPretty = IO Bool
CPretty.supportsPretty
  {-# INLINEABLE supportsPretty #-}

-- | @since 0.1
instance MonadTerminal m => MonadTerminal (ReaderT e m) where
  putStr :: HasCallStack => String -> ReaderT e m ()
putStr = m () -> ReaderT e m ()
forall (m :: * -> *) a. Monad m => m a -> ReaderT e m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ReaderT e m ())
-> (String -> m ()) -> String -> ReaderT e m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> m ()
forall (m :: * -> *).
(MonadTerminal m, HasCallStack) =>
String -> m ()
putStr
  {-# INLINEABLE putStr #-}
  putStrLn :: HasCallStack => String -> ReaderT e m ()
putStrLn = m () -> ReaderT e m ()
forall (m :: * -> *) a. Monad m => m a -> ReaderT e m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ReaderT e m ())
-> (String -> m ()) -> String -> ReaderT e m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> m ()
forall (m :: * -> *).
(MonadTerminal m, HasCallStack) =>
String -> m ()
putStrLn
  {-# INLINEABLE putStrLn #-}
  putBinary :: HasCallStack => ByteString -> ReaderT e m ()
putBinary = m () -> ReaderT e m ()
forall (m :: * -> *) a. Monad m => m a -> ReaderT e m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ReaderT e m ())
-> (ByteString -> m ()) -> ByteString -> ReaderT e m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> m ()
forall (m :: * -> *).
(MonadTerminal m, HasCallStack) =>
ByteString -> m ()
putBinary
  {-# INLINEABLE putBinary #-}
  getChar :: HasCallStack => ReaderT e m Char
getChar = m Char -> ReaderT e m Char
forall (m :: * -> *) a. Monad m => m a -> ReaderT e m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Char
forall (m :: * -> *). (MonadTerminal m, HasCallStack) => m Char
getChar
  {-# INLINEABLE getChar #-}
  getLine :: HasCallStack => ReaderT e m String
getLine = m String -> ReaderT e m String
forall (m :: * -> *) a. Monad m => m a -> ReaderT e m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m String
forall (m :: * -> *). (MonadTerminal m, HasCallStack) => m String
getLine
  {-# INLINEABLE getLine #-}
#if MIN_VERSION_base(4,15,0)
  getContents' :: HasCallStack => ReaderT e m String
getContents' = m String -> ReaderT e m String
forall (m :: * -> *) a. Monad m => m a -> ReaderT e m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m String
forall (m :: * -> *). (MonadTerminal m, HasCallStack) => m String
getContents'
  {-# INLINEABLE getContents' #-}
#endif
  getTerminalSize :: forall a. (HasCallStack, Integral a) => ReaderT e m (Window a)
getTerminalSize = m (Window a) -> ReaderT e m (Window a)
forall (m :: * -> *) a. Monad m => m a -> ReaderT e m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m (Window a)
forall a. (HasCallStack, Integral a) => m (Window a)
forall (m :: * -> *) a.
(MonadTerminal m, HasCallStack, Integral a) =>
m (Window a)
getTerminalSize
  {-# INLINEABLE getTerminalSize #-}
  supportsPretty :: HasCallStack => ReaderT e m Bool
supportsPretty = m Bool -> ReaderT e m Bool
forall (m :: * -> *) a. Monad m => m a -> ReaderT e m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Bool
forall (m :: * -> *). (MonadTerminal m, HasCallStack) => m Bool
supportsPretty
  {-# INLINEABLE supportsPretty #-}

{- ORMOLU_ENABLE -}

-- | 'putStrLn' and 'show'.
--
-- @since 0.1
print :: (HasCallStack, MonadTerminal m, Show a) => a -> m ()
print :: forall (m :: * -> *) a.
(HasCallStack, MonadTerminal m, Show a) =>
a -> m ()
print = String -> m ()
forall (m :: * -> *).
(MonadTerminal m, HasCallStack) =>
String -> m ()
putStrLn (String -> m ()) -> (a -> String) -> a -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show
{-# INLINEABLE print #-}

-- | 'Text' version of 'putStr'.
--
-- @since 0.1
putText :: (HasCallStack, MonadTerminal m) => Text -> m ()
putText :: forall (m :: * -> *).
(HasCallStack, MonadTerminal m) =>
Text -> m ()
putText = String -> m ()
forall (m :: * -> *).
(MonadTerminal m, HasCallStack) =>
String -> m ()
putStr (String -> m ()) -> (Text -> String) -> Text -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack
{-# INLINEABLE putText #-}

-- | 'Text' version of 'putStrLn'.
--
-- @since 0.1
putTextLn :: (HasCallStack, MonadTerminal m) => Text -> m ()
putTextLn :: forall (m :: * -> *).
(HasCallStack, MonadTerminal m) =>
Text -> m ()
putTextLn = String -> m ()
forall (m :: * -> *).
(MonadTerminal m, HasCallStack) =>
String -> m ()
putStrLn (String -> m ()) -> (Text -> String) -> Text -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack
{-# INLINEABLE putTextLn #-}

-- | 'Text' version of 'getLine'.
--
-- @since 0.1
getTextLine :: (HasCallStack, MonadTerminal m) => m Text
getTextLine :: forall (m :: * -> *). (HasCallStack, MonadTerminal m) => m Text
getTextLine = String -> Text
T.pack (String -> Text) -> m String -> m Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m String
forall (m :: * -> *). (MonadTerminal m, HasCallStack) => m String
getLine
{-# INLINEABLE getTextLine #-}

#if MIN_VERSION_base(4,15,0)
-- | 'Text' version of 'getContents''.
--
-- @since 0.1
getTextContents' :: (HasCallStack, MonadTerminal m) => m Text
getTextContents' :: forall (m :: * -> *). (HasCallStack, MonadTerminal m) => m Text
getTextContents' = String -> Text
T.pack (String -> Text) -> m String -> m Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m String
forall (m :: * -> *). (MonadTerminal m, HasCallStack) => m String
getContents'
{-# INLINEABLE getTextContents' #-}
#endif

-- | Retrieves the terminal width.
--
-- @since 0.1
getTerminalWidth :: (HasCallStack, Integral a, MonadTerminal m) => m a
getTerminalWidth :: forall a (m :: * -> *).
(HasCallStack, Integral a, MonadTerminal m) =>
m a
getTerminalWidth = Window a -> a
forall a. Window a -> a
width (Window a -> a) -> m (Window a) -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Window a)
forall a. (HasCallStack, Integral a) => m (Window a)
forall (m :: * -> *) a.
(MonadTerminal m, HasCallStack, Integral a) =>
m (Window a)
getTerminalSize
{-# INLINEABLE getTerminalWidth #-}

-- | Retrieves the terminal height.
--
-- @since 0.1
getTerminalHeight :: (HasCallStack, Integral a, MonadTerminal m) => m a
getTerminalHeight :: forall a (m :: * -> *).
(HasCallStack, Integral a, MonadTerminal m) =>
m a
getTerminalHeight = Window a -> a
forall a. Window a -> a
height (Window a -> a) -> m (Window a) -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Window a)
forall a. (HasCallStack, Integral a) => m (Window a)
forall (m :: * -> *) a.
(MonadTerminal m, HasCallStack, Integral a) =>
m (Window a)
getTerminalSize
{-# INLINEABLE getTerminalHeight #-}