vty-6.6: src/Graphics/Vty/Output.hs
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RecordWildCards, CPP #-}
-- | This module provides an abstract interface for performing terminal
-- output and functions for accessing the current terminal or a specific
-- terminal device.
module Graphics.Vty.Output
( Output(..)
, AssumedState(..)
, DisplayContext(..)
, Mode(..)
, displayContext
, outputPicture
, initialAssumedState
, limitAttrForDisplay
, setCursorPos
, hideCursor
, showCursor
)
where
import Blaze.ByteString.Builder (Write, writeToByteString)
import Blaze.ByteString.Builder.ByteString (writeByteString)
import Control.Monad (when)
import qualified Data.ByteString as BS
import Data.IORef
import qualified Data.Vector as Vector
#if !MIN_VERSION_base(4,11,0)
import Data.Monoid ((<>))
#endif
import qualified Data.Text.Encoding as T
import qualified Data.Text.Lazy as TL
import Graphics.Vty.Attributes
import Graphics.Vty.DisplayAttributes
import Graphics.Vty.Image (DisplayRegion, regionWidth, regionHeight)
import Graphics.Vty.Picture
import Graphics.Vty.PictureToSpans
import Graphics.Vty.Span
-- | Modal terminal features that can be enabled and disabled.
data Mode = Mouse
-- ^ Mouse mode (whether the terminal is configured to provide
-- mouse input events)
| BracketedPaste
-- ^ Paste mode (whether the terminal is configured to provide
-- events on OS pastes)
| Focus
-- ^ Focus-in/focus-out events (whether the terminal is
-- configured to provide events on focus change)
| Hyperlink
-- ^ Hyperlink mode via the 'withURL' attribute modifier (see
-- https://gist.github.com/egmontkob/eb114294efbcd5adb1944c9f3cb5feda).
-- Note that this may not work gracefully in all terminal
-- emulators so be sure to test this mode with the terminals
-- you intend to support. It is off by default.
deriving (Eq, Read, Show)
-- | The library's device output abstraction. Platform-specific
-- implementations must implement an 'Output' and provide it to
-- 'Graphics.Vty.mkVtyFromPair'.
data Output = Output
{ -- | Text identifier for the output device. Used for debugging.
terminalID :: String
-- | Release the terminal just prior to application exit and reset
-- it to its state prior to application startup.
, releaseTerminal :: IO ()
-- | Clear the display and initialize the terminal to some initial
-- display state.
--
-- The expectation of a program is that the display starts in some
-- The initial state. initial state would consist of fixed values:
--
-- - cursor at top left
-- - UTF-8 character encoding
-- - drawing characteristics are the default
, reserveDisplay :: IO ()
-- | Return the display to the state before `reserveDisplay` If no
-- previous state then set the display state to the initial state.
, releaseDisplay :: IO ()
-- | Sets the current display bounds (width, height).
, setDisplayBounds :: (Int, Int) -> IO ()
-- | Returns the current display bounds.
, displayBounds :: IO DisplayRegion
-- | Output the bytestring to the terminal device.
, outputByteBuffer :: BS.ByteString -> IO ()
-- | Specifies whether the cursor can be shown / hidden.
, supportsCursorVisibility :: Bool
-- | Indicates support for terminal modes for this output device.
, supportsMode :: Mode -> Bool
-- | Enables or disables a mode (does nothing if the mode is
-- unsupported).
, setMode :: Mode -> Bool -> IO ()
-- | Returns whether a mode is enabled.
, getModeStatus :: Mode -> IO Bool
, assumedStateRef :: IORef AssumedState
-- | Acquire display access to the given region of the display.
-- Currently all regions have the upper left corner of (0,0) and
-- the lower right corner at (max displayWidth providedWidth, max
-- displayHeight providedHeight)
, mkDisplayContext :: Output -> DisplayRegion -> IO DisplayContext
-- | Ring the terminal bell if supported.
, ringTerminalBell :: IO ()
-- | Returns whether the terminal has an audio bell feature.
, supportsBell :: IO Bool
-- | Returns whether the terminal supports italicized text.
--
-- This is terminal-dependent and should make a best effort to
-- determine whether this feature is supported, but even if the
-- terminal advertises support (e.g. via terminfo) that might not
-- be a reliable indicator of whether the feature will work as
-- desired.
, supportsItalics :: IO Bool
-- | Returns whether the terminal supports strikethrough text.
--
-- This is terminal-dependent and should make a best effort to
-- determine whether this feature is supported, but even if the
-- terminal advertises support (e.g. via terminfo) that might not
-- be a reliable indicator of whether the feature will work as
-- desired.
, supportsStrikethrough :: IO Bool
-- | Returns how many colors the terminal supports.
, outputColorMode :: ColorMode
-- | Set the output's window title, if any.
, setOutputWindowTitle :: String -> IO ()
}
-- | Sets the cursor position to the given output column and row.
--
-- This is not necessarily the same as the character position with the
-- same coordinates. Characters can be a variable number of columns in
-- width.
--
-- Currently, the only way to set the cursor position to a given
-- character coordinate is to specify the coordinate in the Picture
-- instance provided to 'outputPicture' or 'refresh'.
setCursorPos :: Output -> Int -> Int -> IO ()
setCursorPos t x y = do
bounds <- displayBounds t
when (x >= 0 && x < regionWidth bounds && y >= 0 && y < regionHeight bounds) $ do
dc <- displayContext t bounds
outputByteBuffer t $ writeToByteString $ writeMoveCursor dc x y
-- | Hides the cursor.
hideCursor :: Output -> IO ()
hideCursor t = do
bounds <- displayBounds t
dc <- displayContext t bounds
outputByteBuffer t $ writeToByteString $ writeHideCursor dc
-- | Shows the cursor.
showCursor :: Output -> IO ()
showCursor t = do
bounds <- displayBounds t
dc <- displayContext t bounds
outputByteBuffer t $ writeToByteString $ writeShowCursor dc
displayContext :: Output -> DisplayRegion -> IO DisplayContext
displayContext t = mkDisplayContext t t
data AssumedState = AssumedState
{ prevFattr :: Maybe FixedAttr
, prevOutputOps :: Maybe DisplayOps
}
initialAssumedState :: AssumedState
initialAssumedState = AssumedState Nothing Nothing
data DisplayContext = DisplayContext
{ contextDevice :: Output
-- | Provide the bounds of the display context.
, contextRegion :: DisplayRegion
-- | Sets the output position to the specified row and column
-- where the number of bytes required for the control codes can be
-- specified seperate from the actual byte sequence.
, writeMoveCursor :: Int -> Int -> Write
, writeShowCursor :: Write
, writeHideCursor :: Write
-- Ensure that the specified output attributes will be applied to
-- all the following text until the next output attribute change
-- where the number of bytes required for the control codes can be
-- specified seperately from the actual byte sequence. The required
-- number of bytes must be at least the maximum number of bytes
-- required by any attribute changes. The serialization equations
-- must provide the ptr to the next byte to be specified in the
-- output buffer.
--
-- The currently applied display attributes are provided as well.
-- The Attr data type can specify the style or color should not be
-- changed from the currently applied display attributes. In order
-- to support this the currently applied display attributes are
-- required. In addition it may be possible to optimize the state
-- changes based off the currently applied display attributes.
, writeSetAttr :: Bool -> FixedAttr -> Attr -> DisplayAttrDiff -> Write
-- | Reset the display attributes to the default display attributes.
, writeDefaultAttr :: Bool -> Write
, writeRowEnd :: Write
-- | See `Graphics.Vty.Output.XTermColor.inlineHack`
, inlineHack :: IO ()
}
-- | All terminals serialize UTF8 text to the terminal device exactly as
-- serialized in memory.
writeUtf8Text :: BS.ByteString -> Write
writeUtf8Text = writeByteString
-- | Displays the given `Picture`.
--
-- 1. The image is cropped to the display size.
--
-- 2. Converted into a sequence of attribute changes and text spans.
--
-- 3. The cursor is hidden.
--
-- 4. Serialized to the display.
--
-- 5. The cursor is then shown and positioned or kept hidden.
outputPicture :: DisplayContext -> Picture -> IO ()
outputPicture dc pic = do
urlsEnabled <- getModeStatus (contextDevice dc) Hyperlink
as <- readIORef (assumedStateRef $ contextDevice dc)
let manipCursor = supportsCursorVisibility (contextDevice dc)
r = contextRegion dc
ops = displayOpsForPic pic r
initialAttr = FixedAttr defaultStyleMask Nothing Nothing Nothing
-- Diff the previous output against the requested output.
-- Differences are currently on a per-row basis.
diffs :: [Bool] = case prevOutputOps as of
Nothing -> replicate (fromEnum $ regionHeight $ affectedRegion ops) True
Just previousOps -> if affectedRegion previousOps /= affectedRegion ops
then replicate (displayOpsRows ops) True
else Vector.toList $ Vector.zipWith (/=) previousOps ops
-- build the Write corresponding to the output image
out = (if manipCursor then writeHideCursor dc else mempty)
`mappend` writeOutputOps urlsEnabled dc initialAttr diffs ops
`mappend`
(let (w,h) = contextRegion dc
clampX = max 0 . min (w-1)
clampY = max 0 . min (h-1) in
case picCursor pic of
_ | not manipCursor -> mempty
NoCursor -> mempty
AbsoluteCursor x y ->
writeShowCursor dc `mappend`
writeMoveCursor dc (clampX x) (clampY y)
PositionOnly isAbs x y ->
if isAbs
then writeMoveCursor dc (clampX x) (clampY y)
else let (ox, oy) = charToOutputPos m (clampX x, clampY y)
m = cursorOutputMap ops $ picCursor pic
in writeMoveCursor dc (clampX ox) (clampY oy)
Cursor x y ->
let m = cursorOutputMap ops $ picCursor pic
(ox, oy) = charToOutputPos m (clampX x, clampY y)
in writeShowCursor dc `mappend`
writeMoveCursor dc (clampX ox) (clampY oy)
)
-- ... then serialize
outputByteBuffer (contextDevice dc) (writeToByteString out)
-- Cache the output spans.
let as' = as { prevOutputOps = Just ops }
writeIORef (assumedStateRef $ contextDevice dc) as'
writeOutputOps :: Bool -> DisplayContext -> FixedAttr -> [Bool] -> DisplayOps -> Write
writeOutputOps urlsEnabled dc initialAttr diffs ops =
let (_, out, _) = Vector.foldl' writeOutputOps'
(0, mempty, diffs)
ops
in out
where
writeOutputOps' (y, out, True : diffs') spanOps
= let spanOut = writeSpanOps urlsEnabled dc y initialAttr spanOps
out' = out `mappend` spanOut
in (y+1, out', diffs')
writeOutputOps' (y, out, False : diffs') _spanOps
= (y + 1, out, diffs')
writeOutputOps' (_y, _out, []) _spanOps
= error "vty - output spans without a corresponding diff."
writeSpanOps :: Bool -> DisplayContext -> Int -> FixedAttr -> SpanOps -> Write
writeSpanOps urlsEnabled dc y initialAttr spanOps =
-- The first operation is to set the cursor to the start of the row
let start = writeMoveCursor dc 0 y `mappend` writeDefaultAttr dc urlsEnabled
-- then the span ops are serialized in the order specified
in fst $ Vector.foldl' (\(out, fattr) op -> case writeSpanOp urlsEnabled dc op fattr of
(opOut, fattr') -> (out `mappend` opOut, fattr')
)
(start, initialAttr)
spanOps
writeSpanOp :: Bool -> DisplayContext -> SpanOp -> FixedAttr -> (Write, FixedAttr)
writeSpanOp urlsEnabled dc (TextSpan attr _ _ str) fattr =
let attr' = limitAttrForDisplay (contextDevice dc) attr
fattr' = fixDisplayAttr fattr attr'
diffs = displayAttrDiffs fattr fattr'
out = writeSetAttr dc urlsEnabled fattr attr' diffs
`mappend` writeUtf8Text (T.encodeUtf8 $ TL.toStrict str)
in (out, fattr')
writeSpanOp _ _ (Skip _) _fattr = error "writeSpanOp for Skip"
writeSpanOp urlsEnabled dc (RowEnd _) fattr = (writeDefaultAttr dc urlsEnabled `mappend` writeRowEnd dc, fattr)
-- | The cursor position is given in X,Y character offsets. Due to
-- multi-column characters this needs to be translated to column, row
-- positions.
data CursorOutputMap = CursorOutputMap
{ charToOutputPos :: (Int, Int) -> (Int, Int)
}
cursorOutputMap :: DisplayOps -> Cursor -> CursorOutputMap
cursorOutputMap spanOps _cursor = CursorOutputMap
{ charToOutputPos = \(cx, cy) -> (cursorColumnOffset spanOps cx cy, cy)
}
cursorColumnOffset :: DisplayOps -> Int -> Int -> Int
cursorColumnOffset ops cx cy =
let cursorRowOps = Vector.unsafeIndex ops (fromEnum cy)
(outOffset, _, _)
= Vector.foldl' ( \(d, currentCx, done) op ->
if done then (d, currentCx, done) else case spanOpHasWidth op of
Nothing -> (d, currentCx, False)
Just (cw, ow) -> case compare cx (currentCx + cw) of
GT -> ( d + ow
, currentCx + cw
, False
)
EQ -> ( d + ow
, currentCx + cw
, True
)
LT -> ( d + columnsToCharOffset (cx - currentCx) op
, currentCx + cw
, True
)
)
(0, 0, False)
cursorRowOps
in outOffset
-- | Not all terminals support all display attributes. This filters a
-- display attribute to what the given terminal can display.
limitAttrForDisplay :: Output -> Attr -> Attr
limitAttrForDisplay t attr
= attr { attrForeColor = clampColor $ attrForeColor attr
, attrBackColor = clampColor $ attrBackColor attr
}
where
clampColor Default = Default
clampColor KeepCurrent = KeepCurrent
clampColor (SetTo c) = clampColor' (outputColorMode t) c
clampColor' NoColor _ = Default
clampColor' ColorMode8 (ISOColor v)
| v >= 8 = SetTo $ ISOColor (v - 8)
| otherwise = SetTo $ ISOColor v
clampColor' ColorMode8 _ = Default
clampColor' ColorMode16 c@(ISOColor _) = SetTo c
clampColor' ColorMode16 _ = Default
clampColor' (ColorMode240 _) c@(ISOColor _) = SetTo c
clampColor' (ColorMode240 colorCount) c@(Color240 n)
| n <= colorCount = SetTo c
| otherwise = Default
clampColor' colorMode@(ColorMode240 _) (RGBColor r g b) =
clampColor' colorMode (color240 r g b)
clampColor' FullColor c = SetTo c