{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
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
data Vty =
Vty { Vty -> Picture -> IO ()
update :: Picture -> IO ()
, Vty -> IO Event
nextEvent :: IO Event
, Vty -> IO (Maybe Event)
nextEventNonblocking :: IO (Maybe Event)
, Vty -> Input
inputIface :: Input
, Vty -> Output
outputIface :: Output
, Vty -> IO ()
refresh :: IO ()
, Vty -> IO ()
shutdown :: IO ()
, Vty -> IO Bool
isShutdown :: IO Bool
}
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
}
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