-- Copyright Corey O'Connor
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE FlexibleContexts #-}
-- | This module provides an abstract interface for performing terminal
-- output. The only user-facing part of this API is 'Output'.
module Graphics.Vty.Output.Interface
  ( Output(..)
  , AssumedState(..)
  , DisplayContext(..)
  , Mode(..)
  , displayContext
  , outputPicture
  , initialAssumedState
  , limitAttrForDisplay
  )
where

import Graphics.Vty.Attributes
import Graphics.Vty.Image (DisplayRegion, regionHeight)
import Graphics.Vty.Picture
import Graphics.Vty.PictureToSpans
import Graphics.Vty.Span

import Graphics.Vty.DisplayAttributes

import Blaze.ByteString.Builder (Write, writeToByteString)
import Blaze.ByteString.Builder.ByteString (writeByteString)

import qualified Data.ByteString as BS
import Data.IORef
import qualified Data.Text.Encoding as T
import qualified Data.Text.Lazy as TL
import qualified Data.Vector as Vector

-- | 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
/= :: Mode -> Mode -> Bool
$c/= :: Mode -> Mode -> Bool
== :: Mode -> Mode -> Bool
$c== :: 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
readListPrec :: ReadPrec [Mode]
$creadListPrec :: ReadPrec [Mode]
readPrec :: ReadPrec Mode
$creadPrec :: ReadPrec Mode
readList :: ReadS [Mode]
$creadList :: ReadS [Mode]
readsPrec :: Int -> ReadS Mode
$creadsPrec :: Int -> ReadS 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
showList :: [Mode] -> ShowS
$cshowList :: [Mode] -> ShowS
show :: Mode -> String
$cshow :: Mode -> String
showsPrec :: Int -> Mode -> ShowS
$cshowsPrec :: Int -> Mode -> ShowS
Show)

-- | The Vty terminal output interface.
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 the maximum number of colors supported by the
      -- context.
    , Output -> Int
contextColorCount :: Int
      -- | 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
    }

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)
                    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 :: Maybe DisplayOps
prevOutputOps = DisplayOps -> Maybe DisplayOps
forall a. a -> Maybe a
Just DisplayOps
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
_ DisplayText
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
$ DisplayText -> Text
TL.toStrict DisplayText
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 :: ((Int, Int) -> (Int, Int)) -> CursorOutputMap
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 :: MaybeDefault Color
attrForeColor = MaybeDefault Color -> MaybeDefault Color
clampColor (MaybeDefault Color -> MaybeDefault Color)
-> MaybeDefault Color -> MaybeDefault Color
forall a b. (a -> b) -> a -> b
$ Attr -> MaybeDefault Color
attrForeColor Attr
attr
           , attrBackColor :: MaybeDefault Color
attrBackColor = MaybeDefault Color -> MaybeDefault Color
clampColor (MaybeDefault Color -> MaybeDefault Color)
-> MaybeDefault Color -> MaybeDefault Color
forall a b. (a -> b) -> a -> b
$ Attr -> MaybeDefault Color
attrBackColor Attr
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)   = Color -> MaybeDefault Color
clampColor' Color
c
        clampColor' :: Color -> MaybeDefault Color
clampColor' (ISOColor Style
v)
            | Output -> Int
contextColorCount Output
t Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
8            = MaybeDefault Color
forall v. MaybeDefault v
Default
            | Output -> Int
contextColorCount Output
t Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
16 Bool -> Bool -> Bool
&& Style
v Style -> Style -> Bool
forall a. Ord a => a -> a -> Bool
>= Style
8 = Color -> MaybeDefault Color
forall v. (Eq v, Show v, Read 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. (Eq v, Show v, Read v) => v -> MaybeDefault v
SetTo (Color -> MaybeDefault Color) -> Color -> MaybeDefault Color
forall a b. (a -> b) -> a -> b
$ Style -> Color
ISOColor Style
v
        clampColor' (Color240 Style
v)
            -- Should we choose closest ISO color?
            | Output -> Int
contextColorCount Output
t Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<  Int
8           = MaybeDefault Color
forall v. MaybeDefault v
Default
            | Output -> Int
contextColorCount Output
t Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<  Int
16          = MaybeDefault Color
forall v. MaybeDefault v
Default
            | Output -> Int
contextColorCount Output
t Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
256         = Color -> MaybeDefault Color
forall v. (Eq v, Show v, Read v) => v -> MaybeDefault v
SetTo (Color -> MaybeDefault Color) -> Color -> MaybeDefault Color
forall a b. (a -> b) -> a -> b
$ Style -> Color
Color240 Style
v
            | Bool
otherwise
                = let Double
p :: Double = Style -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Style
v Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
240.0
                      v' :: Style
v' = Double -> Style
forall a b. (RealFrac a, Integral b) => a -> b
floor (Double -> Style) -> Double -> Style
forall a b. (a -> b) -> a -> b
$ Double
p Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Double) -> Int -> Double
forall a b. (a -> b) -> a -> b
$ Output -> Int
contextColorCount Output
t)
                  in Color -> MaybeDefault Color
forall v. (Eq v, Show v, Read v) => v -> MaybeDefault v
SetTo (Color -> MaybeDefault Color) -> Color -> MaybeDefault Color
forall a b. (a -> b) -> a -> b
$ Style -> Color
Color240 Style
v'