-- Copyright Corey O'Connor
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- | 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
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]
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
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 -> DisplayRegion -> IO ()
setDisplayBounds :: (Int, Int) -> IO ()
      -- | Returns the current display bounds.
    , Output -> IO DisplayRegion
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 -> DisplayRegion -> 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
    }

displayContext :: Output -> DisplayRegion -> IO DisplayContext
displayContext :: Output -> DisplayRegion -> IO DisplayContext
displayContext Output
t = Output -> Output -> DisplayRegion -> 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 forall a. Maybe a
Nothing forall a. Maybe a
Nothing

data DisplayContext = DisplayContext
    { DisplayContext -> Output
contextDevice :: Output
    -- | Provide the bounds of the display context.
    , DisplayContext -> DisplayRegion
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 <- forall a. IORef a -> IO a
readIORef (Output -> IORef AssumedState
assumedStateRef 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 :: DisplayRegion
r = DisplayContext -> DisplayRegion
contextRegion DisplayContext
dc
        ops :: DisplayOps
ops = Picture -> DisplayRegion -> DisplayOps
displayOpsForPic Picture
pic DisplayRegion
r
        initialAttr :: FixedAttr
initialAttr = Style -> Maybe Color -> Maybe Color -> Maybe Text -> FixedAttr
FixedAttr Style
defaultStyleMask forall a. Maybe a
Nothing forall a. Maybe a
Nothing 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 -> forall a. Int -> a -> [a]
replicate (forall a. Enum a => a -> Int
fromEnum forall a b. (a -> b) -> a -> b
$ DisplayRegion -> Int
regionHeight forall a b. (a -> b) -> a -> b
$ DisplayOps -> DisplayRegion
affectedRegion DisplayOps
ops) Bool
True
            Just DisplayOps
previousOps -> if DisplayOps -> DisplayRegion
affectedRegion DisplayOps
previousOps forall a. Eq a => a -> a -> Bool
/= DisplayOps -> DisplayRegion
affectedRegion DisplayOps
ops
                then forall a. Int -> a -> [a]
replicate (DisplayOps -> Int
displayOpsRows DisplayOps
ops) Bool
True
                else forall a. Vector a -> [a]
Vector.toList forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> Vector a -> Vector b -> Vector c
Vector.zipWith 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 forall a. Monoid a => a
mempty)
              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
              forall a. Monoid a => a -> a -> a
`mappend`
                (let (Int
w,Int
h) = DisplayContext -> DisplayRegion
contextRegion DisplayContext
dc
                     clampX :: Int -> Int
clampX = forall a. Ord a => a -> a -> a
max Int
0 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => a -> a -> a
min (Int
wforall a. Num a => a -> a -> a
-Int
1)
                     clampY :: Int -> Int
clampY = forall a. Ord a => a -> a -> a
max Int
0 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => a -> a -> a
min (Int
hforall a. Num a => a -> a -> a
-Int
1) in
                 case Picture -> Cursor
picCursor Picture
pic of
                    Cursor
_ | Bool -> Bool
not Bool
manipCursor -> forall a. Monoid a => a
mempty
                    Cursor
NoCursor            -> forall a. Monoid a => a
mempty
                    AbsoluteCursor Int
x Int
y ->
                        DisplayContext -> Write
writeShowCursor DisplayContext
dc 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 -> DisplayRegion -> DisplayRegion
charToOutputPos CursorOutputMap
m (Int -> Int
clampX Int
x, Int -> Int
clampY Int
y)
                                    m :: CursorOutputMap
m = DisplayOps -> Cursor -> CursorOutputMap
cursorOutputMap DisplayOps
ops 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 forall a b. (a -> b) -> a -> b
$ Picture -> Cursor
picCursor Picture
pic
                            (Int
ox, Int
oy) = CursorOutputMap -> DisplayRegion -> DisplayRegion
charToOutputPos CursorOutputMap
m (Int -> Int
clampX Int
x, Int -> Int
clampY Int
y)
                        in DisplayContext -> Write
writeShowCursor DisplayContext
dc 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 = forall a. a -> Maybe a
Just DisplayOps
ops }
    forall a. IORef a -> a -> IO ()
writeIORef (Output -> IORef AssumedState
assumedStateRef 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]
_) = forall a b. (a -> b -> a) -> a -> Vector b -> a
Vector.foldl' (Int, Write, [Bool]) -> SpanOps -> (Int, Write, [Bool])
writeOutputOps'
                                       (Int
0, 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 forall a. Monoid a => a -> a -> a
`mappend` Write
spanOut
              in (Int
yforall 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 forall a. Num a => a -> a -> a
+ Int
1, Write
out, [Bool]
diffs')
        writeOutputOps' (Int
_y, Write
_out, []) SpanOps
_spanOps
            = 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 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 forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ 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 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
               forall a. Monoid a => a -> a -> a
`mappend` ByteString -> Write
writeUtf8Text (Text -> ByteString
T.encodeUtf8 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 = 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 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 -> DisplayRegion -> DisplayRegion
charToOutputPos :: (Int, Int) -> (Int, Int)
    }

cursorOutputMap :: DisplayOps -> Cursor -> CursorOutputMap
cursorOutputMap :: DisplayOps -> Cursor -> CursorOutputMap
cursorOutputMap DisplayOps
spanOps Cursor
_cursor = CursorOutputMap
    { charToOutputPos :: DisplayRegion -> DisplayRegion
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 = forall a. Vector a -> Int -> a
Vector.unsafeIndex DisplayOps
ops (forall a. Enum a => a -> Int
fromEnum Int
cy)
        (Int
outOffset, 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 DisplayRegion
spanOpHasWidth SpanOp
op of
                            Maybe DisplayRegion
Nothing -> (Int
d, Int
currentCx, Bool
False)
                            Just (Int
cw, Int
ow) -> case forall a. Ord a => a -> a -> Ordering
compare Int
cx (Int
currentCx forall a. Num a => a -> a -> a
+ Int
cw) of
                                    Ordering
GT -> ( Int
d forall a. Num a => a -> a -> a
+ Int
ow
                                          , Int
currentCx forall a. Num a => a -> a -> a
+ Int
cw
                                          , Bool
False
                                          )
                                    Ordering
EQ -> ( Int
d forall a. Num a => a -> a -> a
+ Int
ow
                                          , Int
currentCx forall a. Num a => a -> a -> a
+ Int
cw
                                          , Bool
True
                                          )
                                    Ordering
LT -> ( Int
d forall a. Num a => a -> a -> a
+ Int -> SpanOp -> Int
columnsToCharOffset (Int
cx forall a. Num a => a -> a -> a
- Int
currentCx) SpanOp
op
                                          , Int
currentCx 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 forall a b. (a -> b) -> a -> b
$ Attr -> MaybeDefault Color
attrForeColor Attr
attr
           , attrBackColor :: MaybeDefault Color
attrBackColor = MaybeDefault Color -> MaybeDefault Color
clampColor forall a b. (a -> b) -> a -> b
$ Attr -> MaybeDefault Color
attrBackColor Attr
attr
           }
    where
        clampColor :: MaybeDefault Color -> MaybeDefault Color
clampColor MaybeDefault Color
Default     = forall v. MaybeDefault v
Default
        clampColor MaybeDefault Color
KeepCurrent = 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
_ = forall v. MaybeDefault v
Default

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

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

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

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