{-# 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 (Mode -> Mode -> Bool
(Mode -> Mode -> Bool) -> (Mode -> Mode -> Bool) -> Eq Mode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Mode -> Mode -> Bool
== :: Mode -> Mode -> Bool
$c/= :: Mode -> Mode -> Bool
/= :: Mode -> Mode -> Bool
Eq, ReadPrec [Mode]
ReadPrec Mode
Int -> ReadS Mode
ReadS [Mode]
(Int -> ReadS Mode)
-> ReadS [Mode] -> ReadPrec Mode -> ReadPrec [Mode] -> Read Mode
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS Mode
readsPrec :: Int -> ReadS Mode
$creadList :: ReadS [Mode]
readList :: ReadS [Mode]
$creadPrec :: ReadPrec Mode
readPrec :: ReadPrec Mode
$creadListPrec :: ReadPrec [Mode]
readListPrec :: ReadPrec [Mode]
Read, Int -> Mode -> ShowS
[Mode] -> ShowS
Mode -> String
(Int -> Mode -> ShowS)
-> (Mode -> String) -> ([Mode] -> ShowS) -> Show Mode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Mode -> ShowS
showsPrec :: Int -> Mode -> ShowS
$cshow :: Mode -> String
show :: Mode -> String
$cshowList :: [Mode] -> ShowS
showList :: [Mode] -> ShowS
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.
      Output -> String
terminalID :: String
      -- | Release the terminal just prior to application exit and reset
      -- it to its state prior to application startup.
    , Output -> IO ()
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
    , Output -> IO ()
reserveDisplay :: IO ()
      -- | Return the display to the state before `reserveDisplay` If no
      -- previous state then set the display state to the initial state.
    , Output -> IO ()
releaseDisplay :: IO ()
      -- | Sets the current display bounds (width, height).
    , Output -> (Int, Int) -> IO ()
setDisplayBounds :: (Int, Int) -> IO ()
      -- | Returns the current display bounds.
    , Output -> IO (Int, Int)
displayBounds :: IO DisplayRegion
      -- | Output the bytestring to the terminal device.
    , Output -> ByteString -> IO ()
outputByteBuffer :: BS.ByteString -> IO ()
      -- | Specifies whether the cursor can be shown / hidden.
    , Output -> Bool
supportsCursorVisibility :: Bool
      -- | Indicates support for terminal modes for this output device.
    , Output -> Mode -> Bool
supportsMode :: Mode -> Bool
      -- | Enables or disables a mode (does nothing if the mode is
      -- unsupported).
    , Output -> Mode -> Bool -> IO ()
setMode :: Mode -> Bool -> IO ()
      -- | Returns whether a mode is enabled.
    , Output -> Mode -> IO Bool
getModeStatus :: Mode -> IO Bool
    , Output -> IORef AssumedState
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)
    , Output -> Output -> (Int, Int) -> IO DisplayContext
mkDisplayContext :: Output -> DisplayRegion -> IO DisplayContext
      -- | Ring the terminal bell if supported.
    , Output -> IO ()
ringTerminalBell :: IO ()
      -- | Returns whether the terminal has an audio bell feature.
    , Output -> IO Bool
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.
    , Output -> IO Bool
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.
    , Output -> IO Bool
supportsStrikethrough :: IO Bool
      -- | Returns how many colors the terminal supports.
    , Output -> ColorMode
outputColorMode :: ColorMode
      -- | Set the output's window title, if any.
    , Output -> String -> IO ()
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 :: Output -> Int -> Int -> IO ()
setCursorPos Output
t Int
x Int
y = do
    (Int, Int)
bounds <- Output -> IO (Int, Int)
displayBounds Output
t
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 Bool -> Bool -> Bool
&& Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< (Int, Int) -> Int
regionWidth (Int, Int)
bounds Bool -> Bool -> Bool
&& Int
y Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 Bool -> Bool -> Bool
&& Int
y Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< (Int, Int) -> Int
regionHeight (Int, Int)
bounds) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        DisplayContext
dc <- Output -> (Int, Int) -> IO DisplayContext
displayContext Output
t (Int, Int)
bounds
        Output -> ByteString -> IO ()
outputByteBuffer Output
t (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ Write -> ByteString
writeToByteString (Write -> ByteString) -> Write -> ByteString
forall a b. (a -> b) -> a -> b
$ DisplayContext -> Int -> Int -> Write
writeMoveCursor DisplayContext
dc Int
x Int
y

-- | Hides the cursor.
hideCursor :: Output -> IO ()
hideCursor :: Output -> IO ()
hideCursor Output
t = do
    (Int, Int)
bounds <- Output -> IO (Int, Int)
displayBounds Output
t
    DisplayContext
dc <- Output -> (Int, Int) -> IO DisplayContext
displayContext Output
t (Int, Int)
bounds
    Output -> ByteString -> IO ()
outputByteBuffer Output
t (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ Write -> ByteString
writeToByteString (Write -> ByteString) -> Write -> ByteString
forall a b. (a -> b) -> a -> b
$ DisplayContext -> Write
writeHideCursor DisplayContext
dc

-- | Shows the cursor.
showCursor :: Output -> IO ()
showCursor :: Output -> IO ()
showCursor Output
t = do
    (Int, Int)
bounds <- Output -> IO (Int, Int)
displayBounds Output
t
    DisplayContext
dc <- Output -> (Int, Int) -> IO DisplayContext
displayContext Output
t (Int, Int)
bounds
    Output -> ByteString -> IO ()
outputByteBuffer Output
t (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ Write -> ByteString
writeToByteString (Write -> ByteString) -> Write -> ByteString
forall a b. (a -> b) -> a -> b
$ DisplayContext -> Write
writeShowCursor DisplayContext
dc

displayContext :: Output -> DisplayRegion -> IO DisplayContext
displayContext :: Output -> (Int, Int) -> IO DisplayContext
displayContext Output
t = Output -> Output -> (Int, Int) -> IO DisplayContext
mkDisplayContext Output
t Output
t

data AssumedState = AssumedState
    { AssumedState -> Maybe FixedAttr
prevFattr :: Maybe FixedAttr
    , AssumedState -> Maybe DisplayOps
prevOutputOps :: Maybe DisplayOps
    }

initialAssumedState :: AssumedState
initialAssumedState :: AssumedState
initialAssumedState = Maybe FixedAttr -> Maybe DisplayOps -> AssumedState
AssumedState Maybe FixedAttr
forall a. Maybe a
Nothing Maybe DisplayOps
forall a. Maybe a
Nothing

data DisplayContext = DisplayContext
    { DisplayContext -> Output
contextDevice :: Output
    -- | Provide the bounds of the display context.
    , DisplayContext -> (Int, Int)
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.
    , DisplayContext -> Int -> Int -> Write
writeMoveCursor :: Int -> Int -> Write
    , DisplayContext -> Write
writeShowCursor :: Write
    , DisplayContext -> 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.
    , DisplayContext
-> Bool -> FixedAttr -> Attr -> DisplayAttrDiff -> Write
writeSetAttr :: Bool -> FixedAttr -> Attr -> DisplayAttrDiff -> Write
    -- | Reset the display attributes to the default display attributes.
    , DisplayContext -> Bool -> Write
writeDefaultAttr :: Bool -> Write
    , DisplayContext -> Write
writeRowEnd :: Write
    -- | See `Graphics.Vty.Output.XTermColor.inlineHack`
    , DisplayContext -> IO ()
inlineHack :: IO ()
    }

-- | All terminals serialize UTF8 text to the terminal device exactly as
-- serialized in memory.
writeUtf8Text  :: BS.ByteString -> Write
writeUtf8Text :: ByteString -> Write
writeUtf8Text = ByteString -> Write
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 :: DisplayContext -> Picture -> IO ()
outputPicture DisplayContext
dc Picture
pic = do
    Bool
urlsEnabled <- Output -> Mode -> IO Bool
getModeStatus (DisplayContext -> Output
contextDevice DisplayContext
dc) Mode
Hyperlink
    AssumedState
as <- IORef AssumedState -> IO AssumedState
forall a. IORef a -> IO a
readIORef (Output -> IORef AssumedState
assumedStateRef (Output -> IORef AssumedState) -> Output -> IORef AssumedState
forall a b. (a -> b) -> a -> b
$ DisplayContext -> Output
contextDevice DisplayContext
dc)
    let manipCursor :: Bool
manipCursor = Output -> Bool
supportsCursorVisibility (DisplayContext -> Output
contextDevice DisplayContext
dc)
        r :: (Int, Int)
r = DisplayContext -> (Int, Int)
contextRegion DisplayContext
dc
        ops :: DisplayOps
ops = Picture -> (Int, Int) -> DisplayOps
displayOpsForPic Picture
pic (Int, Int)
r
        initialAttr :: FixedAttr
initialAttr = Style -> Maybe Color -> Maybe Color -> Maybe Text -> FixedAttr
FixedAttr Style
defaultStyleMask Maybe Color
forall a. Maybe a
Nothing Maybe Color
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing
        -- Diff the previous output against the requested output.
        -- Differences are currently on a per-row basis.
        [Bool]
diffs :: [Bool] = case AssumedState -> Maybe DisplayOps
prevOutputOps AssumedState
as of
            Maybe DisplayOps
Nothing -> Int -> Bool -> [Bool]
forall a. Int -> a -> [a]
replicate (Int -> Int
forall a. Enum a => a -> Int
fromEnum (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> Int
regionHeight ((Int, Int) -> Int) -> (Int, Int) -> Int
forall a b. (a -> b) -> a -> b
$ DisplayOps -> (Int, Int)
affectedRegion DisplayOps
ops) Bool
True
            Just DisplayOps
previousOps -> if DisplayOps -> (Int, Int)
affectedRegion DisplayOps
previousOps (Int, Int) -> (Int, Int) -> Bool
forall a. Eq a => a -> a -> Bool
/= DisplayOps -> (Int, Int)
affectedRegion DisplayOps
ops
                then Int -> Bool -> [Bool]
forall a. Int -> a -> [a]
replicate (DisplayOps -> Int
displayOpsRows DisplayOps
ops) Bool
True
                else Vector Bool -> [Bool]
forall a. Vector a -> [a]
Vector.toList (Vector Bool -> [Bool]) -> Vector Bool -> [Bool]
forall a b. (a -> b) -> a -> b
$ (SpanOps -> SpanOps -> Bool)
-> DisplayOps -> DisplayOps -> Vector Bool
forall a b c. (a -> b -> c) -> Vector a -> Vector b -> Vector c
Vector.zipWith SpanOps -> SpanOps -> Bool
forall a. Eq a => a -> a -> Bool
(/=) DisplayOps
previousOps DisplayOps
ops
        -- build the Write corresponding to the output image
        out :: Write
out = (if Bool
manipCursor then DisplayContext -> Write
writeHideCursor DisplayContext
dc else Write
forall a. Monoid a => a
mempty)
              Write -> Write -> Write
forall a. Monoid a => a -> a -> a
`mappend` Bool
-> DisplayContext -> FixedAttr -> [Bool] -> DisplayOps -> Write
writeOutputOps Bool
urlsEnabled DisplayContext
dc FixedAttr
initialAttr [Bool]
diffs DisplayOps
ops
              Write -> Write -> Write
forall a. Monoid a => a -> a -> a
`mappend`
                (let (Int
w,Int
h) = DisplayContext -> (Int, Int)
contextRegion DisplayContext
dc
                     clampX :: Int -> Int
clampX = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int -> Int) -> (Int -> Int) -> Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Int
wInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
                     clampY :: Int -> Int
clampY = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int -> Int) -> (Int -> Int) -> Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Int
hInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) in
                 case Picture -> Cursor
picCursor Picture
pic of
                    Cursor
_ | Bool -> Bool
not Bool
manipCursor -> Write
forall a. Monoid a => a
mempty
                    Cursor
NoCursor            -> Write
forall a. Monoid a => a
mempty
                    AbsoluteCursor Int
x Int
y ->
                        DisplayContext -> Write
writeShowCursor DisplayContext
dc Write -> Write -> Write
forall a. Monoid a => a -> a -> a
`mappend`
                        DisplayContext -> Int -> Int -> Write
writeMoveCursor DisplayContext
dc (Int -> Int
clampX Int
x) (Int -> Int
clampY Int
y)
                    PositionOnly Bool
isAbs Int
x Int
y ->
                        if Bool
isAbs
                           then DisplayContext -> Int -> Int -> Write
writeMoveCursor DisplayContext
dc (Int -> Int
clampX Int
x) (Int -> Int
clampY Int
y)
                           else let (Int
ox, Int
oy) = CursorOutputMap -> (Int, Int) -> (Int, Int)
charToOutputPos CursorOutputMap
m (Int -> Int
clampX Int
x, Int -> Int
clampY Int
y)
                                    m :: CursorOutputMap
m = DisplayOps -> Cursor -> CursorOutputMap
cursorOutputMap DisplayOps
ops (Cursor -> CursorOutputMap) -> Cursor -> CursorOutputMap
forall a b. (a -> b) -> a -> b
$ Picture -> Cursor
picCursor Picture
pic
                                in DisplayContext -> Int -> Int -> Write
writeMoveCursor DisplayContext
dc (Int -> Int
clampX Int
ox) (Int -> Int
clampY Int
oy)
                    Cursor Int
x Int
y           ->
                        let m :: CursorOutputMap
m = DisplayOps -> Cursor -> CursorOutputMap
cursorOutputMap DisplayOps
ops (Cursor -> CursorOutputMap) -> Cursor -> CursorOutputMap
forall a b. (a -> b) -> a -> b
$ Picture -> Cursor
picCursor Picture
pic
                            (Int
ox, Int
oy) = CursorOutputMap -> (Int, Int) -> (Int, Int)
charToOutputPos CursorOutputMap
m (Int -> Int
clampX Int
x, Int -> Int
clampY Int
y)
                        in DisplayContext -> Write
writeShowCursor DisplayContext
dc Write -> Write -> Write
forall a. Monoid a => a -> a -> a
`mappend`
                           DisplayContext -> Int -> Int -> Write
writeMoveCursor DisplayContext
dc (Int -> Int
clampX Int
ox) (Int -> Int
clampY Int
oy)
                )
    -- ... then serialize
    Output -> ByteString -> IO ()
outputByteBuffer (DisplayContext -> Output
contextDevice DisplayContext
dc) (Write -> ByteString
writeToByteString Write
out)
    -- Cache the output spans.
    let as' :: AssumedState
as' = AssumedState
as { prevOutputOps = Just ops }
    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
as'

writeOutputOps :: Bool -> DisplayContext -> FixedAttr -> [Bool] -> DisplayOps -> Write
writeOutputOps :: Bool
-> DisplayContext -> FixedAttr -> [Bool] -> DisplayOps -> Write
writeOutputOps Bool
urlsEnabled DisplayContext
dc FixedAttr
initialAttr [Bool]
diffs DisplayOps
ops =
    let (Int
_, Write
out, [Bool]
_) = ((Int, Write, [Bool]) -> SpanOps -> (Int, Write, [Bool]))
-> (Int, Write, [Bool]) -> DisplayOps -> (Int, Write, [Bool])
forall a b. (a -> b -> a) -> a -> Vector b -> a
Vector.foldl' (Int, Write, [Bool]) -> SpanOps -> (Int, Write, [Bool])
writeOutputOps'
                                       (Int
0, Write
forall a. Monoid a => a
mempty, [Bool]
diffs)
                                       DisplayOps
ops
    in Write
out
    where
        writeOutputOps' :: (Int, Write, [Bool]) -> SpanOps -> (Int, Write, [Bool])
writeOutputOps' (Int
y, Write
out, Bool
True : [Bool]
diffs') SpanOps
spanOps
            = let spanOut :: Write
spanOut = Bool -> DisplayContext -> Int -> FixedAttr -> SpanOps -> Write
writeSpanOps Bool
urlsEnabled DisplayContext
dc Int
y FixedAttr
initialAttr SpanOps
spanOps
                  out' :: Write
out' = Write
out Write -> Write -> Write
forall a. Monoid a => a -> a -> a
`mappend` Write
spanOut
              in (Int
yInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1, Write
out', [Bool]
diffs')
        writeOutputOps' (Int
y, Write
out, Bool
False : [Bool]
diffs') SpanOps
_spanOps
            = (Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Write
out, [Bool]
diffs')
        writeOutputOps' (Int
_y, Write
_out, []) SpanOps
_spanOps
            = String -> (Int, Write, [Bool])
forall a. HasCallStack => String -> a
error String
"vty - output spans without a corresponding diff."

writeSpanOps :: Bool -> DisplayContext -> Int -> FixedAttr -> SpanOps -> Write
writeSpanOps :: Bool -> DisplayContext -> Int -> FixedAttr -> SpanOps -> Write
writeSpanOps Bool
urlsEnabled DisplayContext
dc Int
y FixedAttr
initialAttr SpanOps
spanOps =
    -- The first operation is to set the cursor to the start of the row
    let start :: Write
start = DisplayContext -> Int -> Int -> Write
writeMoveCursor DisplayContext
dc Int
0 Int
y Write -> Write -> Write
forall a. Monoid a => a -> a -> a
`mappend` DisplayContext -> Bool -> Write
writeDefaultAttr DisplayContext
dc Bool
urlsEnabled
    -- then the span ops are serialized in the order specified
    in (Write, FixedAttr) -> Write
forall a b. (a, b) -> a
fst ((Write, FixedAttr) -> Write) -> (Write, FixedAttr) -> Write
forall a b. (a -> b) -> a -> b
$ ((Write, FixedAttr) -> SpanOp -> (Write, FixedAttr))
-> (Write, FixedAttr) -> SpanOps -> (Write, FixedAttr)
forall a b. (a -> b -> a) -> a -> Vector b -> a
Vector.foldl' (\(Write
out, FixedAttr
fattr) SpanOp
op -> case Bool -> DisplayContext -> SpanOp -> FixedAttr -> (Write, FixedAttr)
writeSpanOp Bool
urlsEnabled DisplayContext
dc SpanOp
op FixedAttr
fattr of
                              (Write
opOut, FixedAttr
fattr') -> (Write
out Write -> Write -> Write
forall a. Monoid a => a -> a -> a
`mappend` Write
opOut, FixedAttr
fattr')
                           )
                           (Write
start, FixedAttr
initialAttr)
                           SpanOps
spanOps

writeSpanOp :: Bool -> DisplayContext -> SpanOp -> FixedAttr -> (Write, FixedAttr)
writeSpanOp :: Bool -> DisplayContext -> SpanOp -> FixedAttr -> (Write, FixedAttr)
writeSpanOp Bool
urlsEnabled DisplayContext
dc (TextSpan Attr
attr Int
_ Int
_ Text
str) FixedAttr
fattr =
    let attr' :: Attr
attr' = Output -> Attr -> Attr
limitAttrForDisplay (DisplayContext -> Output
contextDevice DisplayContext
dc) Attr
attr
        fattr' :: FixedAttr
fattr' = FixedAttr -> Attr -> FixedAttr
fixDisplayAttr FixedAttr
fattr Attr
attr'
        diffs :: DisplayAttrDiff
diffs = FixedAttr -> FixedAttr -> DisplayAttrDiff
displayAttrDiffs FixedAttr
fattr FixedAttr
fattr'
        out :: Write
out =  DisplayContext
-> Bool -> FixedAttr -> Attr -> DisplayAttrDiff -> Write
writeSetAttr DisplayContext
dc Bool
urlsEnabled FixedAttr
fattr Attr
attr' DisplayAttrDiff
diffs
               Write -> Write -> Write
forall a. Monoid a => a -> a -> a
`mappend` ByteString -> Write
writeUtf8Text (Text -> ByteString
T.encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> Text
TL.toStrict Text
str)
    in (Write
out, FixedAttr
fattr')
writeSpanOp Bool
_ DisplayContext
_ (Skip Int
_) FixedAttr
_fattr = String -> (Write, FixedAttr)
forall a. HasCallStack => String -> a
error String
"writeSpanOp for Skip"
writeSpanOp Bool
urlsEnabled DisplayContext
dc (RowEnd Int
_) FixedAttr
fattr = (DisplayContext -> Bool -> Write
writeDefaultAttr DisplayContext
dc Bool
urlsEnabled Write -> Write -> Write
forall a. Monoid a => a -> a -> a
`mappend` DisplayContext -> Write
writeRowEnd DisplayContext
dc, FixedAttr
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
    { CursorOutputMap -> (Int, Int) -> (Int, Int)
charToOutputPos :: (Int, Int) -> (Int, Int)
    }

cursorOutputMap :: DisplayOps -> Cursor -> CursorOutputMap
cursorOutputMap :: DisplayOps -> Cursor -> CursorOutputMap
cursorOutputMap DisplayOps
spanOps Cursor
_cursor = CursorOutputMap
    { charToOutputPos :: (Int, Int) -> (Int, Int)
charToOutputPos = \(Int
cx, Int
cy) -> (DisplayOps -> Int -> Int -> Int
cursorColumnOffset DisplayOps
spanOps Int
cx Int
cy, Int
cy)
    }

cursorColumnOffset :: DisplayOps -> Int -> Int -> Int
cursorColumnOffset :: DisplayOps -> Int -> Int -> Int
cursorColumnOffset DisplayOps
ops Int
cx Int
cy =
    let cursorRowOps :: SpanOps
cursorRowOps = DisplayOps -> Int -> SpanOps
forall a. Vector a -> Int -> a
Vector.unsafeIndex DisplayOps
ops (Int -> Int
forall a. Enum a => a -> Int
fromEnum Int
cy)
        (Int
outOffset, Int
_, Bool
_)
            = ((Int, Int, Bool) -> SpanOp -> (Int, Int, Bool))
-> (Int, Int, Bool) -> SpanOps -> (Int, Int, Bool)
forall a b. (a -> b -> a) -> a -> Vector b -> a
Vector.foldl' ( \(Int
d, Int
currentCx, Bool
done) SpanOp
op ->
                        if Bool
done then (Int
d, Int
currentCx, Bool
done) else case SpanOp -> Maybe (Int, Int)
spanOpHasWidth SpanOp
op of
                            Maybe (Int, Int)
Nothing -> (Int
d, Int
currentCx, Bool
False)
                            Just (Int
cw, Int
ow) -> case Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
cx (Int
currentCx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
cw) of
                                    Ordering
GT -> ( Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
ow
                                          , Int
currentCx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
cw
                                          , Bool
False
                                          )
                                    Ordering
EQ -> ( Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
ow
                                          , Int
currentCx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
cw
                                          , Bool
True
                                          )
                                    Ordering
LT -> ( Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int -> SpanOp -> Int
columnsToCharOffset (Int
cx Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
currentCx) SpanOp
op
                                          , Int
currentCx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
cw
                                          , Bool
True
                                          )
                      )
                      (Int
0, Int
0, Bool
False)
                      SpanOps
cursorRowOps
    in Int
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 :: Output -> Attr -> Attr
limitAttrForDisplay Output
t Attr
attr
    = Attr
attr { attrForeColor = clampColor $ attrForeColor attr
           , attrBackColor = clampColor $ attrBackColor attr
           }
    where
        clampColor :: MaybeDefault Color -> MaybeDefault Color
clampColor MaybeDefault Color
Default     = MaybeDefault Color
forall v. MaybeDefault v
Default
        clampColor MaybeDefault Color
KeepCurrent = MaybeDefault Color
forall v. MaybeDefault v
KeepCurrent
        clampColor (SetTo Color
c)   = ColorMode -> Color -> MaybeDefault Color
clampColor' (Output -> ColorMode
outputColorMode Output
t) Color
c

        clampColor' :: ColorMode -> Color -> MaybeDefault Color
clampColor' ColorMode
NoColor Color
_ = MaybeDefault Color
forall v. MaybeDefault v
Default

        clampColor' ColorMode
ColorMode8 (ISOColor Style
v)
            | Style
v Style -> Style -> Bool
forall a. Ord a => a -> a -> Bool
>= Style
8    = Color -> MaybeDefault Color
forall v. v -> MaybeDefault v
SetTo (Color -> MaybeDefault Color) -> Color -> MaybeDefault Color
forall a b. (a -> b) -> a -> b
$ Style -> Color
ISOColor (Style
v Style -> Style -> Style
forall a. Num a => a -> a -> a
- Style
8)
            | Bool
otherwise = Color -> MaybeDefault Color
forall v. v -> MaybeDefault v
SetTo (Color -> MaybeDefault Color) -> Color -> MaybeDefault Color
forall a b. (a -> b) -> a -> b
$ Style -> Color
ISOColor Style
v
        clampColor' ColorMode
ColorMode8 Color
_ = MaybeDefault Color
forall v. MaybeDefault v
Default

        clampColor' ColorMode
ColorMode16 c :: Color
c@(ISOColor Style
_) = Color -> MaybeDefault Color
forall v. v -> MaybeDefault v
SetTo Color
c
        clampColor' ColorMode
ColorMode16 Color
_              = MaybeDefault Color
forall v. MaybeDefault v
Default

        clampColor' (ColorMode240 Style
_) c :: Color
c@(ISOColor Style
_) = Color -> MaybeDefault Color
forall v. v -> MaybeDefault v
SetTo Color
c
        clampColor' (ColorMode240 Style
colorCount) c :: Color
c@(Color240 Style
n)
            | Style
n Style -> Style -> Bool
forall a. Ord a => a -> a -> Bool
<= Style
colorCount = Color -> MaybeDefault Color
forall v. v -> MaybeDefault v
SetTo Color
c
            | Bool
otherwise       = MaybeDefault Color
forall v. MaybeDefault v
Default
        clampColor' colorMode :: ColorMode
colorMode@(ColorMode240 Style
_) (RGBColor Style
r Style
g Style
b) =
            ColorMode -> Color -> MaybeDefault Color
clampColor' ColorMode
colorMode (Style -> Style -> Style -> Color
forall i. Integral i => i -> i -> i -> Color
color240 Style
r Style
g Style
b)

        clampColor' ColorMode
FullColor Color
c = Color -> MaybeDefault Color
forall v. v -> MaybeDefault v
SetTo Color
c