{-# LANGUAGE CPP #-}
module Graphics.Vty
( Vty(..)
, mkVty
, 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 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 appConfig :: 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 c :: Config
c = do
let doLog :: [Char] -> IO ()
doLog s :: [Char]
s = case Config -> Maybe [Char]
debugLog Config
c of
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just path :: [Char]
path -> [Char] -> [Char] -> IO ()
appendFile [Char]
path ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ "installWidthTable: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
s [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> "\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 [Char]
mTerm <- IO (Maybe [Char])
currentTerminalName
case Maybe [Char]
mTerm of
Nothing ->
[Char] -> IO ()
doLog "No current terminal name available"
Just currentTerm :: [Char]
currentTerm ->
case [Char] -> [([Char], [Char])] -> Maybe [Char]
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup [Char]
currentTerm (Config -> [([Char], [Char])]
termWidthMaps Config
c) of
Nothing ->
[Char] -> IO ()
doLog "Current terminal not found in custom character width mapping list"
Just path :: [Char]
path -> do
Either SomeException (Either [Char] UnicodeWidthTable)
tableResult <- IO (Either [Char] UnicodeWidthTable)
-> IO (Either SomeException (Either [Char] UnicodeWidthTable))
forall e a. Exception e => IO a -> IO (Either e a)
E.try (IO (Either [Char] UnicodeWidthTable)
-> IO (Either SomeException (Either [Char] UnicodeWidthTable)))
-> IO (Either [Char] UnicodeWidthTable)
-> IO (Either SomeException (Either [Char] UnicodeWidthTable))
forall a b. (a -> b) -> a -> b
$ [Char] -> IO (Either [Char] UnicodeWidthTable)
readUnicodeWidthTable [Char]
path
case Either SomeException (Either [Char] UnicodeWidthTable)
tableResult of
Left (SomeException
e::E.SomeException) ->
[Char] -> IO ()
doLog ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ "Error reading custom character width table " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<>
"at " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
path [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> ": " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> SomeException -> [Char]
forall a. Show a => a -> [Char]
show SomeException
e
Right (Left msg :: [Char]
msg) ->
[Char] -> IO ()
doLog ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ "Error reading custom character width table " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<>
"at " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
path [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> ": " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
msg
Right (Right table :: 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) ->
[Char] -> IO ()
doLog ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ "Error installing unicode table (" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<>
[Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
path [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> ": " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> SomeException -> [Char]
forall a. Show a => a -> [Char]
show SomeException
e
Right () ->
[Char] -> IO ()
doLog ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ "Successfully installed Unicode width table " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<>
" from " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
path
internalMkVty :: Input -> Output -> IO Vty
internalMkVty :: Input -> Output -> IO Vty
internalMkVty input :: Input
input out :: Output
out = do
Output -> IO ()
reserveDisplay Output
out
TVar Bool
shutdownVar <- STM (TVar Bool) -> IO (TVar Bool)
forall a. STM a -> IO a
atomically (STM (TVar Bool) -> IO (TVar Bool))
-> STM (TVar Bool) -> IO (TVar Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> STM (TVar Bool)
forall a. a -> STM (TVar a)
newTVar 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 = 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 -> STM Bool
forall a. TVar a -> STM a
readTVar 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 inPic :: 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
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 (lastBounds, 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 _ _) -> IO Event
mkResize
_ -> 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 _ _)) -> 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 -> 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
}