{-# 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 <- (forall a. Semigroup a => a -> a -> a
<> Config
appConfig) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Config
userConfig

    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Config -> Maybe Bool
allowCustomUnicodeWidthTables Config
config forall a. Eq a => a -> a -> Bool
/= forall a. a -> Maybe a
Just Bool
False) 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Just String
path -> String -> String -> IO ()
appendFile String
path forall a b. (a -> b) -> a -> b
$ String
"installWidthTable: " forall a. Semigroup a => a -> a -> a
<> String
s forall a. Semigroup a => a -> a -> a
<> String
"\n"

    Bool
customInstalled <- IO Bool
isCustomTableReady
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
customInstalled) 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 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 <- forall e a. Exception e => IO a -> IO (Either e a)
E.try 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 forall a b. (a -> b) -> a -> b
$ String
"Error reading custom character width table " forall a. Semigroup a => a -> a -> a
<>
                                        String
"at " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show String
path forall a. Semigroup a => a -> a -> a
<> String
": " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show SomeException
e
                            Right (Left String
msg) ->
                                String -> IO ()
doLog forall a b. (a -> b) -> a -> b
$ String
"Error reading custom character width table " forall a. Semigroup a => a -> a -> a
<>
                                        String
"at " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show String
path forall a. Semigroup a => a -> a -> a
<> String
": " forall a. Semigroup a => a -> a -> a
<> String
msg
                            Right (Right UnicodeWidthTable
table) -> do
                                Either SomeException ()
installResult <- forall e a. Exception e => IO a -> IO (Either e a)
E.try 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 forall a b. (a -> b) -> a -> b
$ String
"Error installing unicode table (" forall a. Semigroup a => a -> a -> a
<>
                                                forall a. Show a => a -> String
show String
path forall a. Semigroup a => a -> a -> a
<> String
": " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show SomeException
e
                                    Right () ->
                                        String -> IO ()
doLog forall a b. (a -> b) -> a -> b
$ String
"Successfully installed Unicode width table " forall a. Semigroup a => a -> a -> a
<>
                                                String
" from " forall a. Semigroup a => a -> a -> a
<> 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 <- forall a. a -> IO (TVar a)
newTVarIO Bool
False
    let shutdownIo :: IO ()
shutdownIo = do
            Bool
alreadyShutdown <- forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> a -> STM a
swapTVar TVar Bool
shutdownVar Bool
True
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
alreadyShutdown) 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 = forall a. TVar a -> IO a
readTVarIO TVar Bool
shutdownVar

    IORef (Maybe Picture)
lastPicRef <- forall a. a -> IO (IORef a)
newIORef forall a. Maybe a
Nothing
    IORef (Maybe (DisplayRegion, DisplayContext))
lastUpdateRef <- forall a. a -> IO (IORef a)
newIORef 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 <- 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
                    forall (m :: * -> *) a. Monad m => a -> m a
return (DisplayRegion
b, DisplayContext
dc)
                Just (DisplayRegion
lastBounds, DisplayContext
lastContext) -> do
                    if DisplayRegion
b 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
                            forall (m :: * -> *) a. Monad m => a -> m a
return (DisplayRegion
b, DisplayContext
dc)
                        else do
                            DisplayContext -> Picture -> IO ()
outputPicture DisplayContext
lastContext Picture
inPic
                            forall (m :: * -> *) a. Monad m => a -> m a
return (DisplayRegion
b, DisplayContext
lastContext)
            forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe (DisplayRegion, DisplayContext))
lastUpdateRef forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (DisplayRegion, DisplayContext)
updateData
            forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe Picture)
lastPicRef forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Picture
inPic

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

    let mkResize :: IO Event
mkResize = forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Int -> Int -> Event
EvResize 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)    = forall (m :: * -> *) a. Monad m => a -> m a
return Event
e

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

    forall (m :: * -> *) a. Monad m => a -> m a
return 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 = 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 forall a b. (a -> b) -> a -> b
$ String
"\ESC]2;" forall a. Semigroup a => a -> a -> a
<> String -> String
sanitize String
title forall a. Semigroup a => a -> a -> a
<> String
"\007"
    Output -> ByteString -> IO ()
outputByteBuffer (Vty -> Output
outputIface Vty
vty) ByteString
buf