{-# 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 { update :: Picture -> IO ()
, nextEvent :: IO Event
, nextEventNonblocking :: IO (Maybe Event)
, inputIface :: Input
, outputIface :: Output
, refresh :: IO ()
, shutdown :: IO ()
, isShutdown :: IO Bool
}
mkVty :: Config -> IO Vty
mkVty appConfig = do
config <- (<> appConfig) <$> userConfig
when (allowCustomUnicodeWidthTables config /= Just False) $
installCustomWidthTable config
input <- inputForConfig config
out <- outputForConfig config
internalMkVty input out
installCustomWidthTable :: Config -> IO ()
installCustomWidthTable c = do
let doLog s = case debugLog c of
Nothing -> return ()
Just path -> appendFile path $ "installWidthTable: " <> s <> "\n"
customInstalled <- isCustomTableReady
when (not customInstalled) $ do
mTerm <- currentTerminalName
case mTerm of
Nothing ->
doLog "No current terminal name available"
Just currentTerm ->
case lookup currentTerm (termWidthMaps c) of
Nothing ->
doLog "Current terminal not found in custom character width mapping list"
Just path -> do
tableResult <- E.try $ readUnicodeWidthTable path
case tableResult of
Left (e::E.SomeException) ->
doLog $ "Error reading custom character width table " <>
"at " <> show path <> ": " <> show e
Right (Left msg) ->
doLog $ "Error reading custom character width table " <>
"at " <> show path <> ": " <> msg
Right (Right table) -> do
installResult <- E.try $ installUnicodeWidthTable table
case installResult of
Left (e::E.SomeException) ->
doLog $ "Error installing unicode table (" <>
show path <> ": " <> show e
Right () ->
doLog $ "Successfully installed Unicode width table " <>
" from " <> show path
internalMkVty :: Input -> Output -> IO Vty
internalMkVty input out = do
reserveDisplay out
shutdownVar <- atomically $ newTVar False
let shutdownIo = do
alreadyShutdown <- atomically $ swapTVar shutdownVar True
when (not alreadyShutdown) $ do
shutdownInput input
releaseDisplay out
releaseTerminal out
let shutdownStatus = atomically $ readTVar shutdownVar
lastPicRef <- newIORef Nothing
lastUpdateRef <- newIORef Nothing
let innerUpdate inPic = do
b <- displayBounds out
mlastUpdate <- readIORef lastUpdateRef
updateData <- case mlastUpdate of
Nothing -> do
dc <- displayContext out b
outputPicture dc inPic
return (b, dc)
Just (lastBounds, lastContext) -> do
if b /= lastBounds
then do
dc <- displayContext out b
outputPicture dc inPic
return (b, dc)
else do
outputPicture lastContext inPic
return (b, lastContext)
writeIORef lastUpdateRef $ Just updateData
writeIORef lastPicRef $ Just inPic
let innerRefresh = do
writeIORef lastUpdateRef Nothing
bounds <- displayBounds out
dc <- displayContext out bounds
writeIORef (assumedStateRef $ contextDevice dc) initialAssumedState
mPic <- readIORef lastPicRef
maybe (return ()) innerUpdate mPic
let mkResize = uncurry EvResize <$> displayBounds out
gkey = do
k <- atomically $ readTChan $ _eventChannel input
case k of
(EvResize _ _) -> mkResize
_ -> return k
gkey' = do
k <- atomically $ tryReadTChan $ _eventChannel input
case k of
(Just (EvResize _ _)) -> Just <$> mkResize
_ -> return k
return $ Vty { update = innerUpdate
, nextEvent = gkey
, nextEventNonblocking = gkey'
, inputIface = input
, outputIface = out
, refresh = innerRefresh
, shutdown = shutdownIo
, isShutdown = shutdownStatus
}
setWindowTitle :: Vty -> String -> IO ()
setWindowTitle vty title = do
let sanitize :: String -> String
sanitize = concatMap sanitizeChar
sanitizeChar c | not (isPrint c) = showLitChar c ""
| otherwise = [c]
let buf = BS8.pack $ "\ESC]2;" <> sanitize title <> "\007"
outputByteBuffer (outputIface vty) buf