{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | Vty provides interfaces for both terminal input and terminal
-- output.
--
-- - Input to the terminal is provided to the Vty application as a
--   sequence of 'Event's.
--
-- - Output is provided to Vty by the application in the form of a
--   'Picture'. A 'Picture' is one or more layers of 'Image's.
--   'Image' values can be built by the various constructors in
--   "Graphics.Vty.Image". Output can be syled using 'Attr' (attribute)
--   values in the "Graphics.Vty.Attributes" module.
--
-- Vty uses threads internally, so programs made with Vty need to be
-- compiled with the threaded runtime using the GHC @-threaded@ option.
--
-- @
--  import "Graphics.Vty"
--
--  main = do
--      cfg <- 'standardIOConfig'
--      vty <- 'mkVty' cfg
--      let line0 = 'string' ('defAttr' ` 'withForeColor' ` 'green') \"first line\"
--          line1 = 'string' ('defAttr' ` 'withBackColor' ` 'blue') \"second line\"
--          img = line0 '<->' line1
--          pic = 'picForImage' img
--      'update' vty pic
--      e <- 'nextEvent' vty
--      'shutdown' vty
--      'print' (\"Last event was: \" '++' 'show' e)
-- @
module Graphics.Vty
  ( Vty(..)
  , mkVty
  , setWindowTitle
  , Mode(..)
  , module Graphics.Vty.Config
  , module Graphics.Vty.Input
  , module Graphics.Vty.Output
  , module Graphics.Vty.Output.Interface
  , module Graphics.Vty.Picture
  , module Graphics.Vty.Image
  , module Graphics.Vty.Attributes
  )
where

import Graphics.Vty.Config
import Graphics.Vty.Input
import Graphics.Vty.Input.Events
import Graphics.Vty.Output
import Graphics.Vty.Output.Interface
import Graphics.Vty.Picture
import Graphics.Vty.Image
import Graphics.Vty.Attributes
import Graphics.Vty.UnicodeWidthTable.IO
import Graphics.Vty.UnicodeWidthTable.Install

import Data.Char (isPrint, showLitChar)
import qualified Data.ByteString.Char8 as BS8

import qualified Control.Exception as E
import Control.Monad (when)
import Control.Concurrent.STM

import Data.IORef
#if !(MIN_VERSION_base(4,11,0))
import Data.Semigroup ((<>))
#endif

-- | A Vty value represents a handle to the Vty library that the
-- application must create in order to use Vty.
--
-- The use of Vty typically follows this process:
--
--    1. Initialize vty with 'mkVty' (this takes control of the terminal).
--
--    2. Use 'update' to display a picture.
--
--    3. Use 'nextEvent' to get the next input event.
--
--    4. Depending on the event, go to 2 or 5.
--
--    5. Shutdown vty and restore the terminal state with 'shutdown'. At
--    this point the 'Vty' handle cannot be used again.
--
-- Operations on Vty handles are not thread-safe.
data Vty =
    Vty { Vty -> Picture -> IO ()
update :: Picture -> IO ()
        -- ^ Outputs the given 'Picture'.
        , Vty -> IO Event
nextEvent :: IO Event
        -- ^ Return the next 'Event' or block until one becomes
        -- available.
        , Vty -> IO (Maybe Event)
nextEventNonblocking :: IO (Maybe Event)
        -- ^ Non-blocking version of 'nextEvent'.
        , Vty -> Input
inputIface :: Input
        -- ^ The input interface. See 'Input'.
        , Vty -> Output
outputIface :: Output
        -- ^ The output interface. See 'Output'.
        , Vty -> IO ()
refresh :: IO ()
        -- ^ Refresh the display. If other programs output to the
        -- terminal and mess up the display then the application might
        -- want to force a refresh using this function.
        , Vty -> IO ()
shutdown :: IO ()
        -- ^ Clean up after vty. A call to this function is necessary to
        -- cleanly restore the terminal state before application exit.
        -- The above methods will throw an exception if executed after
        -- this is executed. Idempotent.
        , Vty -> IO Bool
isShutdown :: IO Bool
        }

-- | Create a Vty handle. At most one handle should be created at a time
-- for a given terminal device.
--
-- The specified configuration is added to the the configuration
-- loaded by 'userConfig' with the 'userConfig' configuration taking
-- precedence. See "Graphics.Vty.Config".
--
-- For most applications @mkVty defaultConfig@ is sufficient.
mkVty :: Config -> IO Vty
mkVty :: Config -> IO Vty
mkVty Config
appConfig = do
    Config
config <- (Config -> Config -> Config
forall a. Semigroup a => a -> a -> a
<> Config
appConfig) (Config -> Config) -> IO Config -> IO Config
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Config
userConfig

    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Config -> Maybe Bool
allowCustomUnicodeWidthTables Config
config Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
/= Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        Config -> IO ()
installCustomWidthTable Config
config

    Input
input <- Config -> IO Input
inputForConfig Config
config
    Output
out <- Config -> IO Output
outputForConfig Config
config
    Input -> Output -> IO Vty
internalMkVty Input
input Output
out

installCustomWidthTable :: Config -> IO ()
installCustomWidthTable :: Config -> IO ()
installCustomWidthTable Config
c = do
    let doLog :: String -> IO ()
doLog String
s = case Config -> Maybe String
debugLog Config
c of
            Maybe String
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Just String
path -> String -> String -> IO ()
appendFile String
path (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"installWidthTable: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
s String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n"

    Bool
customInstalled <- IO Bool
isCustomTableReady
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
customInstalled) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Maybe String
mTerm <- IO (Maybe String)
currentTerminalName
        case Maybe String
mTerm of
            Maybe String
Nothing ->
                String -> IO ()
doLog String
"No current terminal name available"
            Just String
currentTerm ->
                case String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
currentTerm (Config -> [(String, String)]
termWidthMaps Config
c) of
                    Maybe String
Nothing ->
                        String -> IO ()
doLog String
"Current terminal not found in custom character width mapping list"
                    Just String
path -> do
                        Either SomeException (Either String UnicodeWidthTable)
tableResult <- IO (Either String UnicodeWidthTable)
-> IO (Either SomeException (Either String UnicodeWidthTable))
forall e a. Exception e => IO a -> IO (Either e a)
E.try (IO (Either String UnicodeWidthTable)
 -> IO (Either SomeException (Either String UnicodeWidthTable)))
-> IO (Either String UnicodeWidthTable)
-> IO (Either SomeException (Either String UnicodeWidthTable))
forall a b. (a -> b) -> a -> b
$ String -> IO (Either String UnicodeWidthTable)
readUnicodeWidthTable String
path
                        case Either SomeException (Either String UnicodeWidthTable)
tableResult of
                            Left (SomeException
e::E.SomeException) ->
                                String -> IO ()
doLog (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Error reading custom character width table " String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
                                        String
"at " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
forall a. Show a => a -> String
show String
path String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> SomeException -> String
forall a. Show a => a -> String
show SomeException
e
                            Right (Left String
msg) ->
                                String -> IO ()
doLog (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Error reading custom character width table " String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
                                        String
"at " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
forall a. Show a => a -> String
show String
path String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
msg
                            Right (Right UnicodeWidthTable
table) -> do
                                Either SomeException ()
installResult <- IO () -> IO (Either SomeException ())
forall e a. Exception e => IO a -> IO (Either e a)
E.try (IO () -> IO (Either SomeException ()))
-> IO () -> IO (Either SomeException ())
forall a b. (a -> b) -> a -> b
$ UnicodeWidthTable -> IO ()
installUnicodeWidthTable UnicodeWidthTable
table
                                case Either SomeException ()
installResult of
                                    Left (SomeException
e::E.SomeException) ->
                                        String -> IO ()
doLog (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Error installing unicode table (" String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
                                                String -> String
forall a. Show a => a -> String
show String
path String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> SomeException -> String
forall a. Show a => a -> String
show SomeException
e
                                    Right () ->
                                        String -> IO ()
doLog (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Successfully installed Unicode width table " String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
                                                String
" from " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
forall a. Show a => a -> String
show String
path

internalMkVty :: Input -> Output -> IO Vty
internalMkVty :: Input -> Output -> IO Vty
internalMkVty Input
input Output
out = do
    Output -> IO ()
reserveDisplay Output
out

    TVar Bool
shutdownVar <- Bool -> IO (TVar Bool)
forall a. a -> IO (TVar a)
newTVarIO Bool
False
    let shutdownIo :: IO ()
shutdownIo = do
            Bool
alreadyShutdown <- STM Bool -> IO Bool
forall a. STM a -> IO a
atomically (STM Bool -> IO Bool) -> STM Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ TVar Bool -> Bool -> STM Bool
forall a. TVar a -> a -> STM a
swapTVar TVar Bool
shutdownVar Bool
True
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
alreadyShutdown) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                Input -> IO ()
shutdownInput Input
input
                Output -> IO ()
releaseDisplay Output
out
                Output -> IO ()
releaseTerminal Output
out

    let shutdownStatus :: IO Bool
shutdownStatus = TVar Bool -> IO Bool
forall a. TVar a -> IO a
readTVarIO TVar Bool
shutdownVar

    IORef (Maybe Picture)
lastPicRef <- Maybe Picture -> IO (IORef (Maybe Picture))
forall a. a -> IO (IORef a)
newIORef Maybe Picture
forall a. Maybe a
Nothing
    IORef (Maybe (DisplayRegion, DisplayContext))
lastUpdateRef <- Maybe (DisplayRegion, DisplayContext)
-> IO (IORef (Maybe (DisplayRegion, DisplayContext)))
forall a. a -> IO (IORef a)
newIORef Maybe (DisplayRegion, DisplayContext)
forall a. Maybe a
Nothing

    let innerUpdate :: Picture -> IO ()
innerUpdate Picture
inPic = do
            DisplayRegion
b <- Output -> IO DisplayRegion
displayBounds Output
out
            Maybe (DisplayRegion, DisplayContext)
mlastUpdate <- IORef (Maybe (DisplayRegion, DisplayContext))
-> IO (Maybe (DisplayRegion, DisplayContext))
forall a. IORef a -> IO a
readIORef IORef (Maybe (DisplayRegion, DisplayContext))
lastUpdateRef
            (DisplayRegion, DisplayContext)
updateData <- case Maybe (DisplayRegion, DisplayContext)
mlastUpdate of
                Maybe (DisplayRegion, DisplayContext)
Nothing -> do
                    DisplayContext
dc <- Output -> DisplayRegion -> IO DisplayContext
displayContext Output
out DisplayRegion
b
                    DisplayContext -> Picture -> IO ()
outputPicture DisplayContext
dc Picture
inPic
                    (DisplayRegion, DisplayContext)
-> IO (DisplayRegion, DisplayContext)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (DisplayRegion
b, DisplayContext
dc)
                Just (DisplayRegion
lastBounds, DisplayContext
lastContext) -> do
                    if DisplayRegion
b DisplayRegion -> DisplayRegion -> Bool
forall a. Eq a => a -> a -> Bool
/= DisplayRegion
lastBounds
                        then do
                            DisplayContext
dc <- Output -> DisplayRegion -> IO DisplayContext
displayContext Output
out DisplayRegion
b
                            DisplayContext -> Picture -> IO ()
outputPicture DisplayContext
dc Picture
inPic
                            (DisplayRegion, DisplayContext)
-> IO (DisplayRegion, DisplayContext)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (DisplayRegion
b, DisplayContext
dc)
                        else do
                            DisplayContext -> Picture -> IO ()
outputPicture DisplayContext
lastContext Picture
inPic
                            (DisplayRegion, DisplayContext)
-> IO (DisplayRegion, DisplayContext)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (DisplayRegion
b, DisplayContext
lastContext)
            IORef (Maybe (DisplayRegion, DisplayContext))
-> Maybe (DisplayRegion, DisplayContext) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe (DisplayRegion, DisplayContext))
lastUpdateRef (Maybe (DisplayRegion, DisplayContext) -> IO ())
-> Maybe (DisplayRegion, DisplayContext) -> IO ()
forall a b. (a -> b) -> a -> b
$ (DisplayRegion, DisplayContext)
-> Maybe (DisplayRegion, DisplayContext)
forall a. a -> Maybe a
Just (DisplayRegion, DisplayContext)
updateData
            IORef (Maybe Picture) -> Maybe Picture -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe Picture)
lastPicRef (Maybe Picture -> IO ()) -> Maybe Picture -> IO ()
forall a b. (a -> b) -> a -> b
$ Picture -> Maybe Picture
forall a. a -> Maybe a
Just Picture
inPic

    let innerRefresh :: IO ()
innerRefresh = do
            IORef (Maybe (DisplayRegion, DisplayContext))
-> Maybe (DisplayRegion, DisplayContext) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe (DisplayRegion, DisplayContext))
lastUpdateRef Maybe (DisplayRegion, DisplayContext)
forall a. Maybe a
Nothing
            DisplayRegion
bounds <- Output -> IO DisplayRegion
displayBounds Output
out
            DisplayContext
dc <- Output -> DisplayRegion -> IO DisplayContext
displayContext Output
out DisplayRegion
bounds
            IORef AssumedState -> AssumedState -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Output -> IORef AssumedState
assumedStateRef (Output -> IORef AssumedState) -> Output -> IORef AssumedState
forall a b. (a -> b) -> a -> b
$ DisplayContext -> Output
contextDevice DisplayContext
dc) AssumedState
initialAssumedState
            Maybe Picture
mPic <- IORef (Maybe Picture) -> IO (Maybe Picture)
forall a. IORef a -> IO a
readIORef IORef (Maybe Picture)
lastPicRef
            IO () -> (Picture -> IO ()) -> Maybe Picture -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) Picture -> IO ()
innerUpdate Maybe Picture
mPic

    let mkResize :: IO Event
mkResize = (Int -> Int -> Event) -> DisplayRegion -> Event
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Int -> Int -> Event
EvResize (DisplayRegion -> Event) -> IO DisplayRegion -> IO Event
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Output -> IO DisplayRegion
displayBounds Output
out

        translateInternalEvent :: InternalEvent -> IO Event
translateInternalEvent InternalEvent
ResumeAfterSignal = IO Event
mkResize
        translateInternalEvent (InputEvent Event
e)    = Event -> IO Event
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Event
e

        gkey :: IO Event
gkey = do
            InternalEvent
e <- STM InternalEvent -> IO InternalEvent
forall a. STM a -> IO a
atomically (STM InternalEvent -> IO InternalEvent)
-> STM InternalEvent -> IO InternalEvent
forall a b. (a -> b) -> a -> b
$ TChan InternalEvent -> STM InternalEvent
forall a. TChan a -> STM a
readTChan (TChan InternalEvent -> STM InternalEvent)
-> TChan InternalEvent -> STM InternalEvent
forall a b. (a -> b) -> a -> b
$ Input -> TChan InternalEvent
_eventChannel Input
input
            InternalEvent -> IO Event
translateInternalEvent InternalEvent
e
        gkey' :: IO (Maybe Event)
gkey' = do
            Maybe InternalEvent
mEv <- STM (Maybe InternalEvent) -> IO (Maybe InternalEvent)
forall a. STM a -> IO a
atomically (STM (Maybe InternalEvent) -> IO (Maybe InternalEvent))
-> STM (Maybe InternalEvent) -> IO (Maybe InternalEvent)
forall a b. (a -> b) -> a -> b
$ TChan InternalEvent -> STM (Maybe InternalEvent)
forall a. TChan a -> STM (Maybe a)
tryReadTChan (TChan InternalEvent -> STM (Maybe InternalEvent))
-> TChan InternalEvent -> STM (Maybe InternalEvent)
forall a b. (a -> b) -> a -> b
$ Input -> TChan InternalEvent
_eventChannel Input
input
            case Maybe InternalEvent
mEv of
                Just InternalEvent
e  -> Event -> Maybe Event
forall a. a -> Maybe a
Just (Event -> Maybe Event) -> IO Event -> IO (Maybe Event)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> InternalEvent -> IO Event
translateInternalEvent InternalEvent
e
                Maybe InternalEvent
Nothing -> Maybe Event -> IO (Maybe Event)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Event
forall a. Maybe a
Nothing

    Vty -> IO Vty
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Vty -> IO Vty) -> Vty -> IO Vty
forall a b. (a -> b) -> a -> b
$ Vty { update :: Picture -> IO ()
update = Picture -> IO ()
innerUpdate
                 , nextEvent :: IO Event
nextEvent = IO Event
gkey
                 , nextEventNonblocking :: IO (Maybe Event)
nextEventNonblocking = IO (Maybe Event)
gkey'
                 , inputIface :: Input
inputIface = Input
input
                 , outputIface :: Output
outputIface = Output
out
                 , refresh :: IO ()
refresh = IO ()
innerRefresh
                 , shutdown :: IO ()
shutdown = IO ()
shutdownIo
                 , isShutdown :: IO Bool
isShutdown = IO Bool
shutdownStatus
                 }

-- | Set the terminal window title string.
--
-- This function emits an Xterm-compatible escape sequence that we
-- anticipate will work for essentially all modern terminal emulators.
-- Ideally we'd use a terminal capability for this, but there does not
-- seem to exist a termcap for setting window titles. If you find that
-- this function does not work for a given terminal emulator, please
-- report the issue.
--
-- For details, see:
--
-- https://tldp.org/HOWTO/Xterm-Title-3.html
setWindowTitle :: Vty -> String -> IO ()
setWindowTitle :: Vty -> String -> IO ()
setWindowTitle Vty
vty String
title = do
    let sanitize :: String -> String
        sanitize :: String -> String
sanitize = (Char -> String) -> String -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Char -> String
sanitizeChar
        sanitizeChar :: Char -> String
sanitizeChar Char
c | Bool -> Bool
not (Char -> Bool
isPrint Char
c) = Char -> String -> String
showLitChar Char
c String
""
                       | Bool
otherwise = [Char
c]
    let buf :: ByteString
buf = String -> ByteString
BS8.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ String
"\ESC]2;" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
sanitize String
title String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\007"
    Output -> ByteString -> IO ()
outputByteBuffer (Vty -> Output
outputIface Vty
vty) ByteString
buf