{-# LANGUAGE CPP #-}

-- | 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.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 :: [Char] -> IO ()
doLog [Char]
s = case Config -> Maybe [Char]
debugLog Config
c of
            Maybe [Char]
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Just [Char]
path -> [Char] -> [Char] -> IO ()
appendFile [Char]
path ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"installWidthTable: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
s [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"\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 [Char]
mTerm <- IO (Maybe [Char])
currentTerminalName
        case Maybe [Char]
mTerm of
            Maybe [Char]
Nothing ->
                [Char] -> IO ()
doLog [Char]
"No current terminal name available"
            Just [Char]
currentTerm ->
                case [Char] -> [([Char], [Char])] -> Maybe [Char]
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup [Char]
currentTerm (Config -> [([Char], [Char])]
termWidthMaps Config
c) of
                    Maybe [Char]
Nothing ->
                        [Char] -> IO ()
doLog [Char]
"Current terminal not found in custom character width mapping list"
                    Just [Char]
path -> do
                        Either SomeException (Either [Char] UnicodeWidthTable)
tableResult <- IO (Either [Char] UnicodeWidthTable)
-> IO (Either SomeException (Either [Char] UnicodeWidthTable))
forall e a. Exception e => IO a -> IO (Either e a)
E.try (IO (Either [Char] UnicodeWidthTable)
 -> IO (Either SomeException (Either [Char] UnicodeWidthTable)))
-> IO (Either [Char] UnicodeWidthTable)
-> IO (Either SomeException (Either [Char] UnicodeWidthTable))
forall a b. (a -> b) -> a -> b
$ [Char] -> IO (Either [Char] UnicodeWidthTable)
readUnicodeWidthTable [Char]
path
                        case Either SomeException (Either [Char] UnicodeWidthTable)
tableResult of
                            Left (SomeException
e::E.SomeException) ->
                                [Char] -> IO ()
doLog ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Error reading custom character width table " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<>
                                        [Char]
"at " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
path [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
": " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> SomeException -> [Char]
forall a. Show a => a -> [Char]
show SomeException
e
                            Right (Left [Char]
msg) ->
                                [Char] -> IO ()
doLog ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Error reading custom character width table " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<>
                                        [Char]
"at " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
path [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
": " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
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) ->
                                        [Char] -> IO ()
doLog ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Error installing unicode table (" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<>
                                                [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
path [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
": " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> SomeException -> [Char]
forall a. Show a => a -> [Char]
show SomeException
e
                                    Right () ->
                                        [Char] -> IO ()
doLog ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Successfully installed Unicode width table " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<>
                                                [Char]
" from " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
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 <- STM (TVar Bool) -> IO (TVar Bool)
forall a. STM a -> IO a
atomically (STM (TVar Bool) -> IO (TVar Bool))
-> STM (TVar Bool) -> IO (TVar Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> STM (TVar Bool)
forall a. a -> STM (TVar a)
newTVar 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 = 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 -> STM Bool
forall a. TVar a -> STM a
readTVar 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 (m :: * -> *) a. Monad m => a -> m a
return (DisplayRegion
b, DisplayContext
dc)
                Just (lastBounds, 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 (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 (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 (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
        gkey :: IO Event
gkey = do
            Event
k <- STM Event -> IO Event
forall a. STM a -> IO a
atomically (STM Event -> IO Event) -> STM Event -> IO Event
forall a b. (a -> b) -> a -> b
$ TChan Event -> STM Event
forall a. TChan a -> STM a
readTChan (TChan Event -> STM Event) -> TChan Event -> STM Event
forall a b. (a -> b) -> a -> b
$ Input -> TChan Event
_eventChannel Input
input
            case Event
k of
                (EvResize Int
_ Int
_)  -> IO Event
mkResize
                Event
_ -> Event -> IO Event
forall (m :: * -> *) a. Monad m => a -> m a
return Event
k
        gkey' :: IO (Maybe Event)
gkey' = do
            Maybe Event
k <- STM (Maybe Event) -> IO (Maybe Event)
forall a. STM a -> IO a
atomically (STM (Maybe Event) -> IO (Maybe Event))
-> STM (Maybe Event) -> IO (Maybe Event)
forall a b. (a -> b) -> a -> b
$ TChan Event -> STM (Maybe Event)
forall a. TChan a -> STM (Maybe a)
tryReadTChan (TChan Event -> STM (Maybe Event))
-> TChan Event -> STM (Maybe Event)
forall a b. (a -> b) -> a -> b
$ Input -> TChan Event
_eventChannel Input
input
            case Maybe Event
k of
                (Just (EvResize Int
_ Int
_))  -> 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
<$> IO Event
mkResize
                Maybe Event
_ -> Maybe Event -> IO (Maybe Event)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Event
k

    Vty -> IO Vty
forall (m :: * -> *) a. Monad m => a -> m a
return (Vty -> IO Vty) -> Vty -> IO Vty
forall a b. (a -> b) -> a -> b
$ Vty :: (Picture -> IO ())
-> IO Event
-> IO (Maybe Event)
-> Input
-> Output
-> IO ()
-> IO ()
-> IO Bool
-> Vty
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 -> [Char] -> IO ()
setWindowTitle Vty
vty [Char]
title = do
    let sanitize :: String -> String
        sanitize :: [Char] -> [Char]
sanitize = (Char -> [Char]) -> [Char] -> [Char]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Char -> [Char]
sanitizeChar
        sanitizeChar :: Char -> [Char]
sanitizeChar Char
c | Bool -> Bool
not (Char -> Bool
isPrint Char
c) = Char -> [Char] -> [Char]
showLitChar Char
c [Char]
""
                       | Bool
otherwise = [Char
c]
    let buf :: ByteString
buf = [Char] -> ByteString
BS8.pack ([Char] -> ByteString) -> [Char] -> ByteString
forall a b. (a -> b) -> a -> b
$ [Char]
"\ESC]2;" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char] -> [Char]
sanitize [Char]
title [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"\007"
    Output -> ByteString -> IO ()
outputByteBuffer (Vty -> Output
outputIface Vty
vty) ByteString
buf