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

-- | Vty provides interfaces for both terminal input and terminal
-- output.
--
-- - User input to the terminal is provided to the Vty application as a
--   sequence of 'Event's.
--
-- - Output is provided to by the application to Vty 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.
--
-- - Each platform on which Vty is supported provides a package that
--   provides Vty with access to the platform-specific terminal
--   interface. For example, on Unix systems, the @vty-unix@ package
--   must be used to initialize Vty with access to a Unix terminal.
--
-- As a small example, the following program demonstrates the use of Vty
-- on a Unix system using the @vty-unix@ package:
--
-- > import Graphics.Vty
-- > import Graphics.Vty.Platform.Unix (mkVty)
-- >
-- > main = do
-- >     vty <- mkVty defaultConfig
-- >     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)
--
-- Vty uses threads internally, so programs made with Vty must be
-- compiled with the threaded runtime using the GHC @-threaded@ option.
module Graphics.Vty
  ( Vty(..)
  , setWindowTitle
  , installCustomWidthTable
  , mkVtyFromPair
  , module Graphics.Vty.Config
  , module Graphics.Vty.Input
  , module Graphics.Vty.Input.Events
  , module Graphics.Vty.Output
  , 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.Picture
import Graphics.Vty.Image
import Graphics.Vty.Attributes
import Graphics.Vty.UnicodeWidthTable.IO
import Graphics.Vty.UnicodeWidthTable.Install

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 this library typically follows this process:
--
-- 1. Initialize Vty with the 'mkVty' implementation for your
-- platform's Vty package (e.g. @vty-unix@), or, more generically, with
-- 'mkVtyFromPair'. This takes control of (and sets up) 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 ()
        -- ^ Output the given 'Picture' to the terminal.
        , 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
        }

-- | Attempt to load and install a custom character width table into
-- this process.
--
-- This looks up the specified terminal name in the specified width
-- table map and, if a map file path is found, the map is loaded and
-- installed. This is exposed for Vty platform package implementors;
-- application developers should never need to call this.
installCustomWidthTable :: Maybe FilePath
                        -- ^ Optional path to a log file where log
                        -- messages should be written when attempting to
                        -- load a width table.
                        -> Maybe String
                        -- ^ Optional width table entry name (usually
                        -- the terminal name, e.g. value of @TERM@ on
                        -- Unix systems). If omitted, this function does
                        -- not attempt to load a table.
                        -> [(String, FilePath)]
                        -- ^ Mapping from width table entry names to
                        -- width table file paths. This is usually
                        -- obtained from 'configTermWidthMaps' of
                        -- 'VtyUserConfig'.
                        -> IO ()
installCustomWidthTable :: Maybe String -> Maybe String -> [(String, String)] -> IO ()
installCustomWidthTable Maybe String
logPath Maybe String
tblName [(String, String)]
widthMaps = do
    let doLog :: String -> IO ()
doLog String
s = case Maybe String
logPath 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
        case Maybe String
tblName of
            Maybe String
Nothing ->
                String -> IO ()
doLog String
"No terminal name given in the configuration, skipping load"
            Just String
name ->
                case String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
name [(String, String)]
widthMaps of
                    Maybe String
Nothing ->
                        String -> IO ()
doLog (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Width table " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
forall a. Show a => a -> String
show String
name String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" 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

-- | Build a 'Vty' handle from an input/output pair.
--
-- This is exposed for Vty platform package implementors; application
-- developers should never need to call this, and should instead call
-- @mkVty@ or equivalent from their platform package of choice.
mkVtyFromPair :: Input -> Output -> IO Vty
mkVtyFromPair :: Input -> Output -> IO Vty
mkVtyFromPair 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

        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

        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

        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
ResumeAfterInterrupt = 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.
setWindowTitle :: Vty -> String -> IO ()
setWindowTitle :: Vty -> String -> IO ()
setWindowTitle Vty
vty String
title =
    Output -> String -> IO ()
setOutputWindowTitle (Vty -> Output
outputIface Vty
vty) String
title