{-# LANGUAGE CPP #-}
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
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 (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 (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 (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
}
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