{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -D_XOPEN_SOURCE=500 -fno-warn-warnings-deprecations #-}
{-# CFILES gwinsz.c #-}

-- | Terminfo-based terminal output driver.
--
-- Copyright Corey O'Connor (coreyoconnor@gmail.com)
module Graphics.Vty.Output.TerminfoBased
  ( reserveTerminal
  , setWindowSize
  )
where

import Control.Monad (when)
import Data.Bits (shiftL, (.&.))
import qualified Data.ByteString as BS
import Data.ByteString.Internal (toForeignPtr)
import Data.Terminfo.Parse
import Data.Terminfo.Eval

import Graphics.Vty.Attributes
import Graphics.Vty.Image (DisplayRegion)
import Graphics.Vty.DisplayAttributes
import Graphics.Vty.Output.Interface

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

import Data.IORef
import Data.Maybe (isJust, isNothing, fromJust)
import Data.Word

#if !MIN_VERSION_base(4,8,0)
import Data.Foldable (foldMap)
#endif

import Foreign.C.Types ( CInt(..), CLong(..) )
import Foreign.ForeignPtr (withForeignPtr)
import Foreign.Ptr (Ptr, plusPtr)

import qualified System.Console.Terminfo as Terminfo
import System.Posix.IO (fdWriteBuf)
import System.Posix.Types (Fd(..))

data TerminfoCaps = TerminfoCaps
    { TerminfoCaps -> Maybe CapExpression
smcup :: Maybe CapExpression
    , TerminfoCaps -> Maybe CapExpression
rmcup :: Maybe CapExpression
    , TerminfoCaps -> CapExpression
cup :: CapExpression
    , TerminfoCaps -> Maybe CapExpression
cnorm :: Maybe CapExpression
    , TerminfoCaps -> Maybe CapExpression
civis :: Maybe CapExpression
    , TerminfoCaps -> Bool
supportsNoColors :: Bool
    , TerminfoCaps -> Bool
useAltColorMap :: Bool
    , TerminfoCaps -> CapExpression
setForeColor :: CapExpression
    , TerminfoCaps -> CapExpression
setBackColor :: CapExpression
    , TerminfoCaps -> CapExpression
setDefaultAttr :: CapExpression
    , TerminfoCaps -> CapExpression
clearScreen :: CapExpression
    , TerminfoCaps -> CapExpression
clearEol :: CapExpression
    , TerminfoCaps -> DisplayAttrCaps
displayAttrCaps :: DisplayAttrCaps
    , TerminfoCaps -> Maybe CapExpression
ringBellAudio :: Maybe CapExpression
    }

data DisplayAttrCaps = DisplayAttrCaps
    { DisplayAttrCaps -> Maybe CapExpression
setAttrStates :: Maybe CapExpression
    , DisplayAttrCaps -> Maybe CapExpression
enterStandout :: Maybe CapExpression
    , DisplayAttrCaps -> Maybe CapExpression
exitStandout :: Maybe CapExpression
    , DisplayAttrCaps -> Maybe CapExpression
enterItalic :: Maybe CapExpression
    , DisplayAttrCaps -> Maybe CapExpression
exitItalic :: Maybe CapExpression
    , DisplayAttrCaps -> Maybe CapExpression
enterStrikethrough :: Maybe CapExpression
    , DisplayAttrCaps -> Maybe CapExpression
exitStrikethrough :: Maybe CapExpression
    , DisplayAttrCaps -> Maybe CapExpression
enterUnderline :: Maybe CapExpression
    , DisplayAttrCaps -> Maybe CapExpression
exitUnderline :: Maybe CapExpression
    , DisplayAttrCaps -> Maybe CapExpression
enterReverseVideo :: Maybe CapExpression
    , DisplayAttrCaps -> Maybe CapExpression
enterDimMode :: Maybe CapExpression
    , DisplayAttrCaps -> Maybe CapExpression
enterBoldMode :: Maybe CapExpression
    }

-- kinda like:
-- https://code.google.com/p/vim/source/browse/src/fileio.c#10422
-- fdWriteBuf will throw on error. Unless the error is EINTR. On EINTR
-- the write will be retried.
fdWriteAll :: Fd -> Ptr Word8 -> Int -> Int -> IO Int
fdWriteAll :: Fd -> Ptr Word8 -> Int -> Int -> IO Int
fdWriteAll Fd
outFd Ptr Word8
ptr Int
len Int
count
    | Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<  Int
0  = String -> IO Int
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"fdWriteAll: len is less than 0"
    | Int
len Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0  = Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
count
    | Bool
otherwise = do
        Int
writeCount <- ByteCount -> Int
forall a. Enum a => a -> Int
fromEnum (ByteCount -> Int) -> IO ByteCount -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Fd -> Ptr Word8 -> ByteCount -> IO ByteCount
fdWriteBuf Fd
outFd Ptr Word8
ptr (Int -> ByteCount
forall a. Enum a => Int -> a
toEnum Int
len)
        let len' :: Int
len' = Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
writeCount
            ptr' :: Ptr b
ptr' = Ptr Word8
ptr Ptr Word8 -> Int -> Ptr b
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
writeCount
            count' :: Int
count' = Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
writeCount
        Fd -> Ptr Word8 -> Int -> Int -> IO Int
fdWriteAll Fd
outFd Ptr Word8
forall b. Ptr b
ptr' Int
len' Int
count'

sendCapToTerminal :: Output -> CapExpression -> [CapParam] -> IO ()
sendCapToTerminal :: Output -> CapExpression -> [CapParam] -> IO ()
sendCapToTerminal Output
t CapExpression
cap [CapParam]
capParams = do
    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
$ CapExpression -> [CapParam] -> Write
writeCapExpr CapExpression
cap [CapParam]
capParams

-- | Constructs an output driver that uses terminfo for all control
-- codes. While this should provide the most compatible terminal,
-- terminfo does not support some features that would increase
-- efficiency and improve compatibility:
--
--  * determining the character encoding supported by the terminal.
--    Should this be taken from the LANG environment variable?
--
--  * Providing independent string capabilities for all display
--    attributes.
reserveTerminal :: String -> Fd -> IO Output
reserveTerminal :: String -> Fd -> IO Output
reserveTerminal String
termName Fd
outFd = do
    Terminal
ti <- String -> IO Terminal
Terminfo.setupTerm String
termName
    -- assumes set foreground always implies set background exists.
    -- if set foreground is not set then all color changing style
    -- attributes are filtered.
    Maybe CapExpression
msetaf <- Terminal -> String -> IO (Maybe CapExpression)
probeCap Terminal
ti String
"setaf"
    Maybe CapExpression
msetf <- Terminal -> String -> IO (Maybe CapExpression)
probeCap Terminal
ti String
"setf"
    let (Bool
noColors, Bool
useAlt, CapExpression
setForeCap)
            = case Maybe CapExpression
msetaf of
                Just CapExpression
setaf -> (Bool
False, Bool
False, CapExpression
setaf)
                Maybe CapExpression
Nothing -> case Maybe CapExpression
msetf of
                    Just CapExpression
setf -> (Bool
False, Bool
True, CapExpression
setf)
                    Maybe CapExpression
Nothing -> (Bool
True, Bool
True, String -> CapExpression
forall a. HasCallStack => String -> a
error (String -> CapExpression) -> String -> CapExpression
forall a b. (a -> b) -> a -> b
$ String
"no fore color support for terminal " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
termName)
    Maybe CapExpression
msetab <- Terminal -> String -> IO (Maybe CapExpression)
probeCap Terminal
ti String
"setab"
    Maybe CapExpression
msetb <- Terminal -> String -> IO (Maybe CapExpression)
probeCap Terminal
ti String
"setb"
    let set_back_cap :: CapExpression
set_back_cap
            = case Maybe CapExpression
msetab of
                Maybe CapExpression
Nothing -> case Maybe CapExpression
msetb of
                    Just CapExpression
setb -> CapExpression
setb
                    Maybe CapExpression
Nothing -> String -> CapExpression
forall a. HasCallStack => String -> a
error (String -> CapExpression) -> String -> CapExpression
forall a b. (a -> b) -> a -> b
$ String
"no back color support for terminal " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
termName
                Just CapExpression
setab -> CapExpression
setab

    IORef Bool
hyperlinkModeStatus <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False
    IORef AssumedState
newAssumedStateRef <- AssumedState -> IO (IORef AssumedState)
forall a. a -> IO (IORef a)
newIORef AssumedState
initialAssumedState

    let terminfoSetMode :: Mode -> Bool -> IO ()
terminfoSetMode Mode
m Bool
newStatus = do
          Bool
curStatus <- Mode -> IO Bool
terminfoModeStatus Mode
m
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
newStatus Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
/= Bool
curStatus) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
              case Mode
m of
                  Mode
Hyperlink -> do
                      IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
hyperlinkModeStatus Bool
newStatus
                      IORef AssumedState -> AssumedState -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef AssumedState
newAssumedStateRef AssumedState
initialAssumedState
                  Mode
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        terminfoModeStatus :: Mode -> IO Bool
terminfoModeStatus Mode
m =
            case Mode
m of
                Mode
Hyperlink -> IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
hyperlinkModeStatus
                Mode
_ -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        terminfoModeSupported :: Mode -> Bool
terminfoModeSupported Mode
Hyperlink = Bool
True
        terminfoModeSupported Mode
_ = Bool
False

    TerminfoCaps
terminfoCaps <- (Maybe CapExpression
 -> Maybe CapExpression
 -> CapExpression
 -> Maybe CapExpression
 -> Maybe CapExpression
 -> Bool
 -> Bool
 -> CapExpression
 -> CapExpression
 -> CapExpression
 -> CapExpression
 -> CapExpression
 -> DisplayAttrCaps
 -> Maybe CapExpression
 -> TerminfoCaps)
-> IO
     (Maybe CapExpression
      -> Maybe CapExpression
      -> CapExpression
      -> Maybe CapExpression
      -> Maybe CapExpression
      -> Bool
      -> Bool
      -> CapExpression
      -> CapExpression
      -> CapExpression
      -> CapExpression
      -> CapExpression
      -> DisplayAttrCaps
      -> Maybe CapExpression
      -> TerminfoCaps)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe CapExpression
-> Maybe CapExpression
-> CapExpression
-> Maybe CapExpression
-> Maybe CapExpression
-> Bool
-> Bool
-> CapExpression
-> CapExpression
-> CapExpression
-> CapExpression
-> CapExpression
-> DisplayAttrCaps
-> Maybe CapExpression
-> TerminfoCaps
TerminfoCaps
        IO
  (Maybe CapExpression
   -> Maybe CapExpression
   -> CapExpression
   -> Maybe CapExpression
   -> Maybe CapExpression
   -> Bool
   -> Bool
   -> CapExpression
   -> CapExpression
   -> CapExpression
   -> CapExpression
   -> CapExpression
   -> DisplayAttrCaps
   -> Maybe CapExpression
   -> TerminfoCaps)
-> IO (Maybe CapExpression)
-> IO
     (Maybe CapExpression
      -> CapExpression
      -> Maybe CapExpression
      -> Maybe CapExpression
      -> Bool
      -> Bool
      -> CapExpression
      -> CapExpression
      -> CapExpression
      -> CapExpression
      -> CapExpression
      -> DisplayAttrCaps
      -> Maybe CapExpression
      -> TerminfoCaps)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Terminal -> String -> IO (Maybe CapExpression)
probeCap Terminal
ti String
"smcup"
        IO
  (Maybe CapExpression
   -> CapExpression
   -> Maybe CapExpression
   -> Maybe CapExpression
   -> Bool
   -> Bool
   -> CapExpression
   -> CapExpression
   -> CapExpression
   -> CapExpression
   -> CapExpression
   -> DisplayAttrCaps
   -> Maybe CapExpression
   -> TerminfoCaps)
-> IO (Maybe CapExpression)
-> IO
     (CapExpression
      -> Maybe CapExpression
      -> Maybe CapExpression
      -> Bool
      -> Bool
      -> CapExpression
      -> CapExpression
      -> CapExpression
      -> CapExpression
      -> CapExpression
      -> DisplayAttrCaps
      -> Maybe CapExpression
      -> TerminfoCaps)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Terminal -> String -> IO (Maybe CapExpression)
probeCap Terminal
ti String
"rmcup"
        IO
  (CapExpression
   -> Maybe CapExpression
   -> Maybe CapExpression
   -> Bool
   -> Bool
   -> CapExpression
   -> CapExpression
   -> CapExpression
   -> CapExpression
   -> CapExpression
   -> DisplayAttrCaps
   -> Maybe CapExpression
   -> TerminfoCaps)
-> IO CapExpression
-> IO
     (Maybe CapExpression
      -> Maybe CapExpression
      -> Bool
      -> Bool
      -> CapExpression
      -> CapExpression
      -> CapExpression
      -> CapExpression
      -> CapExpression
      -> DisplayAttrCaps
      -> Maybe CapExpression
      -> TerminfoCaps)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Terminal -> String -> IO CapExpression
requireCap Terminal
ti String
"cup"
        IO
  (Maybe CapExpression
   -> Maybe CapExpression
   -> Bool
   -> Bool
   -> CapExpression
   -> CapExpression
   -> CapExpression
   -> CapExpression
   -> CapExpression
   -> DisplayAttrCaps
   -> Maybe CapExpression
   -> TerminfoCaps)
-> IO (Maybe CapExpression)
-> IO
     (Maybe CapExpression
      -> Bool
      -> Bool
      -> CapExpression
      -> CapExpression
      -> CapExpression
      -> CapExpression
      -> CapExpression
      -> DisplayAttrCaps
      -> Maybe CapExpression
      -> TerminfoCaps)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Terminal -> String -> IO (Maybe CapExpression)
probeCap Terminal
ti String
"cnorm"
        IO
  (Maybe CapExpression
   -> Bool
   -> Bool
   -> CapExpression
   -> CapExpression
   -> CapExpression
   -> CapExpression
   -> CapExpression
   -> DisplayAttrCaps
   -> Maybe CapExpression
   -> TerminfoCaps)
-> IO (Maybe CapExpression)
-> IO
     (Bool
      -> Bool
      -> CapExpression
      -> CapExpression
      -> CapExpression
      -> CapExpression
      -> CapExpression
      -> DisplayAttrCaps
      -> Maybe CapExpression
      -> TerminfoCaps)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Terminal -> String -> IO (Maybe CapExpression)
probeCap Terminal
ti String
"civis"
        IO
  (Bool
   -> Bool
   -> CapExpression
   -> CapExpression
   -> CapExpression
   -> CapExpression
   -> CapExpression
   -> DisplayAttrCaps
   -> Maybe CapExpression
   -> TerminfoCaps)
-> IO Bool
-> IO
     (Bool
      -> CapExpression
      -> CapExpression
      -> CapExpression
      -> CapExpression
      -> CapExpression
      -> DisplayAttrCaps
      -> Maybe CapExpression
      -> TerminfoCaps)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
noColors
        IO
  (Bool
   -> CapExpression
   -> CapExpression
   -> CapExpression
   -> CapExpression
   -> CapExpression
   -> DisplayAttrCaps
   -> Maybe CapExpression
   -> TerminfoCaps)
-> IO Bool
-> IO
     (CapExpression
      -> CapExpression
      -> CapExpression
      -> CapExpression
      -> CapExpression
      -> DisplayAttrCaps
      -> Maybe CapExpression
      -> TerminfoCaps)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
useAlt
        IO
  (CapExpression
   -> CapExpression
   -> CapExpression
   -> CapExpression
   -> CapExpression
   -> DisplayAttrCaps
   -> Maybe CapExpression
   -> TerminfoCaps)
-> IO CapExpression
-> IO
     (CapExpression
      -> CapExpression
      -> CapExpression
      -> CapExpression
      -> DisplayAttrCaps
      -> Maybe CapExpression
      -> TerminfoCaps)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> CapExpression -> IO CapExpression
forall (f :: * -> *) a. Applicative f => a -> f a
pure CapExpression
setForeCap
        IO
  (CapExpression
   -> CapExpression
   -> CapExpression
   -> CapExpression
   -> DisplayAttrCaps
   -> Maybe CapExpression
   -> TerminfoCaps)
-> IO CapExpression
-> IO
     (CapExpression
      -> CapExpression
      -> CapExpression
      -> DisplayAttrCaps
      -> Maybe CapExpression
      -> TerminfoCaps)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> CapExpression -> IO CapExpression
forall (f :: * -> *) a. Applicative f => a -> f a
pure CapExpression
set_back_cap
        IO
  (CapExpression
   -> CapExpression
   -> CapExpression
   -> DisplayAttrCaps
   -> Maybe CapExpression
   -> TerminfoCaps)
-> IO CapExpression
-> IO
     (CapExpression
      -> CapExpression
      -> DisplayAttrCaps
      -> Maybe CapExpression
      -> TerminfoCaps)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Terminal -> String -> IO CapExpression
requireCap Terminal
ti String
"sgr0"
        IO
  (CapExpression
   -> CapExpression
   -> DisplayAttrCaps
   -> Maybe CapExpression
   -> TerminfoCaps)
-> IO CapExpression
-> IO
     (CapExpression
      -> DisplayAttrCaps -> Maybe CapExpression -> TerminfoCaps)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Terminal -> String -> IO CapExpression
requireCap Terminal
ti String
"clear"
        IO
  (CapExpression
   -> DisplayAttrCaps -> Maybe CapExpression -> TerminfoCaps)
-> IO CapExpression
-> IO (DisplayAttrCaps -> Maybe CapExpression -> TerminfoCaps)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Terminal -> String -> IO CapExpression
requireCap Terminal
ti String
"el"
        IO (DisplayAttrCaps -> Maybe CapExpression -> TerminfoCaps)
-> IO DisplayAttrCaps -> IO (Maybe CapExpression -> TerminfoCaps)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Terminal -> IO DisplayAttrCaps
currentDisplayAttrCaps Terminal
ti
        IO (Maybe CapExpression -> TerminfoCaps)
-> IO (Maybe CapExpression) -> IO TerminfoCaps
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Terminal -> String -> IO (Maybe CapExpression)
probeCap Terminal
ti String
"bel"
    let t :: Output
t = Output :: String
-> IO ()
-> IO ()
-> IO ()
-> ((Int, Int) -> IO ())
-> IO (Int, Int)
-> (ByteString -> IO ())
-> Int
-> Bool
-> (Mode -> Bool)
-> (Mode -> Bool -> IO ())
-> (Mode -> IO Bool)
-> IORef AssumedState
-> (Output -> (Int, Int) -> IO DisplayContext)
-> IO ()
-> IO Bool
-> IO Bool
-> IO Bool
-> Output
Output
            { terminalID :: String
terminalID = String
termName
            , releaseTerminal :: IO ()
releaseTerminal = do
                (TerminfoCaps -> CapExpression) -> [CapParam] -> IO ()
sendCap TerminfoCaps -> CapExpression
setDefaultAttr []
                (TerminfoCaps -> Maybe CapExpression) -> [CapParam] -> IO ()
maybeSendCap TerminfoCaps -> Maybe CapExpression
cnorm []
            , supportsBell :: IO Bool
supportsBell = Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Maybe CapExpression -> Bool
forall a. Maybe a -> Bool
isJust (Maybe CapExpression -> Bool) -> Maybe CapExpression -> Bool
forall a b. (a -> b) -> a -> b
$ TerminfoCaps -> Maybe CapExpression
ringBellAudio TerminfoCaps
terminfoCaps
            , supportsItalics :: IO Bool
supportsItalics = Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ (Maybe CapExpression -> Bool
forall a. Maybe a -> Bool
isJust (Maybe CapExpression -> Bool) -> Maybe CapExpression -> Bool
forall a b. (a -> b) -> a -> b
$ DisplayAttrCaps -> Maybe CapExpression
enterItalic (TerminfoCaps -> DisplayAttrCaps
displayAttrCaps TerminfoCaps
terminfoCaps)) Bool -> Bool -> Bool
&&
                                         (Maybe CapExpression -> Bool
forall a. Maybe a -> Bool
isJust (Maybe CapExpression -> Bool) -> Maybe CapExpression -> Bool
forall a b. (a -> b) -> a -> b
$ DisplayAttrCaps -> Maybe CapExpression
exitItalic (TerminfoCaps -> DisplayAttrCaps
displayAttrCaps TerminfoCaps
terminfoCaps))
            , supportsStrikethrough :: IO Bool
supportsStrikethrough = Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ (Maybe CapExpression -> Bool
forall a. Maybe a -> Bool
isJust (Maybe CapExpression -> Bool) -> Maybe CapExpression -> Bool
forall a b. (a -> b) -> a -> b
$ DisplayAttrCaps -> Maybe CapExpression
enterStrikethrough (TerminfoCaps -> DisplayAttrCaps
displayAttrCaps TerminfoCaps
terminfoCaps)) Bool -> Bool -> Bool
&&
                                               (Maybe CapExpression -> Bool
forall a. Maybe a -> Bool
isJust (Maybe CapExpression -> Bool) -> Maybe CapExpression -> Bool
forall a b. (a -> b) -> a -> b
$ DisplayAttrCaps -> Maybe CapExpression
exitStrikethrough (TerminfoCaps -> DisplayAttrCaps
displayAttrCaps TerminfoCaps
terminfoCaps))
            , ringTerminalBell :: IO ()
ringTerminalBell = (TerminfoCaps -> Maybe CapExpression) -> [CapParam] -> IO ()
maybeSendCap TerminfoCaps -> Maybe CapExpression
ringBellAudio []
            , reserveDisplay :: IO ()
reserveDisplay = do
                -- If there is no support for smcup: Clear the screen
                -- and then move the mouse to the home position to
                -- approximate the behavior.
                (TerminfoCaps -> Maybe CapExpression) -> [CapParam] -> IO ()
maybeSendCap TerminfoCaps -> Maybe CapExpression
smcup []
                (TerminfoCaps -> CapExpression) -> [CapParam] -> IO ()
sendCap TerminfoCaps -> CapExpression
clearScreen []
            , releaseDisplay :: IO ()
releaseDisplay = do
                (TerminfoCaps -> Maybe CapExpression) -> [CapParam] -> IO ()
maybeSendCap TerminfoCaps -> Maybe CapExpression
rmcup []
                (TerminfoCaps -> Maybe CapExpression) -> [CapParam] -> IO ()
maybeSendCap TerminfoCaps -> Maybe CapExpression
cnorm []
            , setDisplayBounds :: (Int, Int) -> IO ()
setDisplayBounds = \(Int
w, Int
h) ->
                Fd -> (Int, Int) -> IO ()
setWindowSize Fd
outFd (Int
w, Int
h)
            , displayBounds :: IO (Int, Int)
displayBounds = do
                (Int, Int)
rawSize <- Fd -> IO (Int, Int)
getWindowSize Fd
outFd
                case (Int, Int)
rawSize of
                    (Int
w, Int
h)  | Int
w Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| Int
h Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 -> String -> IO (Int, Int)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO (Int, Int)) -> String -> IO (Int, Int)
forall a b. (a -> b) -> a -> b
$ String
"getwinsize returned < 0 : " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Int, Int) -> String
forall a. Show a => a -> String
show (Int, Int)
rawSize
                            | Bool
otherwise      -> (Int, Int) -> IO (Int, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
w,Int
h)
            , outputByteBuffer :: ByteString -> IO ()
outputByteBuffer = \ByteString
outBytes -> do
                let (ForeignPtr Word8
fptr, Int
offset, Int
len) = ByteString -> (ForeignPtr Word8, Int, Int)
toForeignPtr ByteString
outBytes
                Int
actualLen <- ForeignPtr Word8 -> (Ptr Word8 -> IO Int) -> IO Int
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
fptr
                             ((Ptr Word8 -> IO Int) -> IO Int)
-> (Ptr Word8 -> IO Int) -> IO Int
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
ptr -> Fd -> Ptr Word8 -> Int -> Int -> IO Int
fdWriteAll Fd
outFd (Ptr Word8
ptr Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
offset) Int
len Int
0
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int -> Int
forall a. Enum a => Int -> a
toEnum Int
len Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
actualLen) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Graphics.Vty.Output: outputByteBuffer "
                  String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"length mismatch. " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
len String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" /= " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
actualLen
                  String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" Please report this bug to vty project."
            , contextColorCount :: Int
contextColorCount
                = case TerminfoCaps -> Bool
supportsNoColors TerminfoCaps
terminfoCaps of
                    Bool
False -> case Terminal -> Capability Int -> Maybe Int
forall a. Terminal -> Capability a -> Maybe a
Terminfo.getCapability Terminal
ti (String -> Capability Int
Terminfo.tiGetNum String
"colors" ) of
                        Maybe Int
Nothing -> Int
8
                        Just Int
v -> Int -> Int
forall a. Enum a => Int -> a
toEnum Int
v
                    Bool
True -> Int
1
            , supportsCursorVisibility :: Bool
supportsCursorVisibility = Maybe CapExpression -> Bool
forall a. Maybe a -> Bool
isJust (Maybe CapExpression -> Bool) -> Maybe CapExpression -> Bool
forall a b. (a -> b) -> a -> b
$ TerminfoCaps -> Maybe CapExpression
civis TerminfoCaps
terminfoCaps
            , supportsMode :: Mode -> Bool
supportsMode = Mode -> Bool
terminfoModeSupported
            , setMode :: Mode -> Bool -> IO ()
setMode = Mode -> Bool -> IO ()
terminfoSetMode
            , getModeStatus :: Mode -> IO Bool
getModeStatus = Mode -> IO Bool
terminfoModeStatus
            , assumedStateRef :: IORef AssumedState
assumedStateRef = IORef AssumedState
newAssumedStateRef
            -- I think fix would help assure tActual is the only
            -- reference. I was having issues tho.
            , mkDisplayContext :: Output -> (Int, Int) -> IO DisplayContext
mkDisplayContext = (Output -> TerminfoCaps -> (Int, Int) -> IO DisplayContext
`terminfoDisplayContext` TerminfoCaps
terminfoCaps)
            }
        sendCap :: (TerminfoCaps -> CapExpression) -> [CapParam] -> IO ()
sendCap TerminfoCaps -> CapExpression
s = Output -> CapExpression -> [CapParam] -> IO ()
sendCapToTerminal Output
t (TerminfoCaps -> CapExpression
s TerminfoCaps
terminfoCaps)
        maybeSendCap :: (TerminfoCaps -> Maybe CapExpression) -> [CapParam] -> IO ()
maybeSendCap TerminfoCaps -> Maybe CapExpression
s = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe CapExpression -> Bool
forall a. Maybe a -> Bool
isJust (Maybe CapExpression -> Bool) -> Maybe CapExpression -> Bool
forall a b. (a -> b) -> a -> b
$ TerminfoCaps -> Maybe CapExpression
s TerminfoCaps
terminfoCaps) (IO () -> IO ()) -> ([CapParam] -> IO ()) -> [CapParam] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TerminfoCaps -> CapExpression) -> [CapParam] -> IO ()
sendCap (Maybe CapExpression -> CapExpression
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe CapExpression -> CapExpression)
-> (TerminfoCaps -> Maybe CapExpression)
-> TerminfoCaps
-> CapExpression
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TerminfoCaps -> Maybe CapExpression
s)
    Output -> IO Output
forall (m :: * -> *) a. Monad m => a -> m a
return Output
t

requireCap :: Terminfo.Terminal -> String -> IO CapExpression
requireCap :: Terminal -> String -> IO CapExpression
requireCap Terminal
ti String
capName
    = case Terminal -> Capability String -> Maybe String
forall a. Terminal -> Capability a -> Maybe a
Terminfo.getCapability Terminal
ti (String -> Capability String
Terminfo.tiGetStr String
capName) of
        Maybe String
Nothing     -> String -> IO CapExpression
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO CapExpression) -> String -> IO CapExpression
forall a b. (a -> b) -> a -> b
$ String
"Terminal does not define required capability \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
capName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\""
        Just String
capStr -> String -> IO CapExpression
parseCap String
capStr

probeCap :: Terminfo.Terminal -> String -> IO (Maybe CapExpression)
probeCap :: Terminal -> String -> IO (Maybe CapExpression)
probeCap Terminal
ti String
capName
    = case Terminal -> Capability String -> Maybe String
forall a. Terminal -> Capability a -> Maybe a
Terminfo.getCapability Terminal
ti (String -> Capability String
Terminfo.tiGetStr String
capName) of
        Maybe String
Nothing     -> Maybe CapExpression -> IO (Maybe CapExpression)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe CapExpression
forall a. Maybe a
Nothing
        Just String
capStr -> CapExpression -> Maybe CapExpression
forall a. a -> Maybe a
Just (CapExpression -> Maybe CapExpression)
-> IO CapExpression -> IO (Maybe CapExpression)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO CapExpression
parseCap String
capStr

parseCap :: String -> IO CapExpression
parseCap :: String -> IO CapExpression
parseCap String
capStr = do
    case String -> Either ParseError CapExpression
parseCapExpression String
capStr of
        Left ParseError
e -> String -> IO CapExpression
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO CapExpression) -> String -> IO CapExpression
forall a b. (a -> b) -> a -> b
$ ParseError -> String
forall a. Show a => a -> String
show ParseError
e
        Right CapExpression
cap -> CapExpression -> IO CapExpression
forall (m :: * -> *) a. Monad m => a -> m a
return CapExpression
cap

currentDisplayAttrCaps :: Terminfo.Terminal -> IO DisplayAttrCaps
currentDisplayAttrCaps :: Terminal -> IO DisplayAttrCaps
currentDisplayAttrCaps Terminal
ti
    =   (Maybe CapExpression
 -> Maybe CapExpression
 -> Maybe CapExpression
 -> Maybe CapExpression
 -> Maybe CapExpression
 -> Maybe CapExpression
 -> Maybe CapExpression
 -> Maybe CapExpression
 -> Maybe CapExpression
 -> Maybe CapExpression
 -> Maybe CapExpression
 -> Maybe CapExpression
 -> DisplayAttrCaps)
-> IO
     (Maybe CapExpression
      -> Maybe CapExpression
      -> Maybe CapExpression
      -> Maybe CapExpression
      -> Maybe CapExpression
      -> Maybe CapExpression
      -> Maybe CapExpression
      -> Maybe CapExpression
      -> Maybe CapExpression
      -> Maybe CapExpression
      -> Maybe CapExpression
      -> Maybe CapExpression
      -> DisplayAttrCaps)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe CapExpression
-> Maybe CapExpression
-> Maybe CapExpression
-> Maybe CapExpression
-> Maybe CapExpression
-> Maybe CapExpression
-> Maybe CapExpression
-> Maybe CapExpression
-> Maybe CapExpression
-> Maybe CapExpression
-> Maybe CapExpression
-> Maybe CapExpression
-> DisplayAttrCaps
DisplayAttrCaps
    IO
  (Maybe CapExpression
   -> Maybe CapExpression
   -> Maybe CapExpression
   -> Maybe CapExpression
   -> Maybe CapExpression
   -> Maybe CapExpression
   -> Maybe CapExpression
   -> Maybe CapExpression
   -> Maybe CapExpression
   -> Maybe CapExpression
   -> Maybe CapExpression
   -> Maybe CapExpression
   -> DisplayAttrCaps)
-> IO (Maybe CapExpression)
-> IO
     (Maybe CapExpression
      -> Maybe CapExpression
      -> Maybe CapExpression
      -> Maybe CapExpression
      -> Maybe CapExpression
      -> Maybe CapExpression
      -> Maybe CapExpression
      -> Maybe CapExpression
      -> Maybe CapExpression
      -> Maybe CapExpression
      -> Maybe CapExpression
      -> DisplayAttrCaps)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Terminal -> String -> IO (Maybe CapExpression)
probeCap Terminal
ti String
"sgr"
    IO
  (Maybe CapExpression
   -> Maybe CapExpression
   -> Maybe CapExpression
   -> Maybe CapExpression
   -> Maybe CapExpression
   -> Maybe CapExpression
   -> Maybe CapExpression
   -> Maybe CapExpression
   -> Maybe CapExpression
   -> Maybe CapExpression
   -> Maybe CapExpression
   -> DisplayAttrCaps)
-> IO (Maybe CapExpression)
-> IO
     (Maybe CapExpression
      -> Maybe CapExpression
      -> Maybe CapExpression
      -> Maybe CapExpression
      -> Maybe CapExpression
      -> Maybe CapExpression
      -> Maybe CapExpression
      -> Maybe CapExpression
      -> Maybe CapExpression
      -> Maybe CapExpression
      -> DisplayAttrCaps)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Terminal -> String -> IO (Maybe CapExpression)
probeCap Terminal
ti String
"smso"
    IO
  (Maybe CapExpression
   -> Maybe CapExpression
   -> Maybe CapExpression
   -> Maybe CapExpression
   -> Maybe CapExpression
   -> Maybe CapExpression
   -> Maybe CapExpression
   -> Maybe CapExpression
   -> Maybe CapExpression
   -> Maybe CapExpression
   -> DisplayAttrCaps)
-> IO (Maybe CapExpression)
-> IO
     (Maybe CapExpression
      -> Maybe CapExpression
      -> Maybe CapExpression
      -> Maybe CapExpression
      -> Maybe CapExpression
      -> Maybe CapExpression
      -> Maybe CapExpression
      -> Maybe CapExpression
      -> Maybe CapExpression
      -> DisplayAttrCaps)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Terminal -> String -> IO (Maybe CapExpression)
probeCap Terminal
ti String
"rmso"
    IO
  (Maybe CapExpression
   -> Maybe CapExpression
   -> Maybe CapExpression
   -> Maybe CapExpression
   -> Maybe CapExpression
   -> Maybe CapExpression
   -> Maybe CapExpression
   -> Maybe CapExpression
   -> Maybe CapExpression
   -> DisplayAttrCaps)
-> IO (Maybe CapExpression)
-> IO
     (Maybe CapExpression
      -> Maybe CapExpression
      -> Maybe CapExpression
      -> Maybe CapExpression
      -> Maybe CapExpression
      -> Maybe CapExpression
      -> Maybe CapExpression
      -> Maybe CapExpression
      -> DisplayAttrCaps)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Terminal -> String -> IO (Maybe CapExpression)
probeCap Terminal
ti String
"sitm"
    IO
  (Maybe CapExpression
   -> Maybe CapExpression
   -> Maybe CapExpression
   -> Maybe CapExpression
   -> Maybe CapExpression
   -> Maybe CapExpression
   -> Maybe CapExpression
   -> Maybe CapExpression
   -> DisplayAttrCaps)
-> IO (Maybe CapExpression)
-> IO
     (Maybe CapExpression
      -> Maybe CapExpression
      -> Maybe CapExpression
      -> Maybe CapExpression
      -> Maybe CapExpression
      -> Maybe CapExpression
      -> Maybe CapExpression
      -> DisplayAttrCaps)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Terminal -> String -> IO (Maybe CapExpression)
probeCap Terminal
ti String
"ritm"
    IO
  (Maybe CapExpression
   -> Maybe CapExpression
   -> Maybe CapExpression
   -> Maybe CapExpression
   -> Maybe CapExpression
   -> Maybe CapExpression
   -> Maybe CapExpression
   -> DisplayAttrCaps)
-> IO (Maybe CapExpression)
-> IO
     (Maybe CapExpression
      -> Maybe CapExpression
      -> Maybe CapExpression
      -> Maybe CapExpression
      -> Maybe CapExpression
      -> Maybe CapExpression
      -> DisplayAttrCaps)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Terminal -> String -> IO (Maybe CapExpression)
probeCap Terminal
ti String
"smxx"
    IO
  (Maybe CapExpression
   -> Maybe CapExpression
   -> Maybe CapExpression
   -> Maybe CapExpression
   -> Maybe CapExpression
   -> Maybe CapExpression
   -> DisplayAttrCaps)
-> IO (Maybe CapExpression)
-> IO
     (Maybe CapExpression
      -> Maybe CapExpression
      -> Maybe CapExpression
      -> Maybe CapExpression
      -> Maybe CapExpression
      -> DisplayAttrCaps)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Terminal -> String -> IO (Maybe CapExpression)
probeCap Terminal
ti String
"rmxx"
    IO
  (Maybe CapExpression
   -> Maybe CapExpression
   -> Maybe CapExpression
   -> Maybe CapExpression
   -> Maybe CapExpression
   -> DisplayAttrCaps)
-> IO (Maybe CapExpression)
-> IO
     (Maybe CapExpression
      -> Maybe CapExpression
      -> Maybe CapExpression
      -> Maybe CapExpression
      -> DisplayAttrCaps)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Terminal -> String -> IO (Maybe CapExpression)
probeCap Terminal
ti String
"smul"
    IO
  (Maybe CapExpression
   -> Maybe CapExpression
   -> Maybe CapExpression
   -> Maybe CapExpression
   -> DisplayAttrCaps)
-> IO (Maybe CapExpression)
-> IO
     (Maybe CapExpression
      -> Maybe CapExpression -> Maybe CapExpression -> DisplayAttrCaps)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Terminal -> String -> IO (Maybe CapExpression)
probeCap Terminal
ti String
"rmul"
    IO
  (Maybe CapExpression
   -> Maybe CapExpression -> Maybe CapExpression -> DisplayAttrCaps)
-> IO (Maybe CapExpression)
-> IO
     (Maybe CapExpression -> Maybe CapExpression -> DisplayAttrCaps)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Terminal -> String -> IO (Maybe CapExpression)
probeCap Terminal
ti String
"rev"
    IO (Maybe CapExpression -> Maybe CapExpression -> DisplayAttrCaps)
-> IO (Maybe CapExpression)
-> IO (Maybe CapExpression -> DisplayAttrCaps)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Terminal -> String -> IO (Maybe CapExpression)
probeCap Terminal
ti String
"dim"
    IO (Maybe CapExpression -> DisplayAttrCaps)
-> IO (Maybe CapExpression) -> IO DisplayAttrCaps
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Terminal -> String -> IO (Maybe CapExpression)
probeCap Terminal
ti String
"bold"

foreign import ccall "gwinsz.h vty_c_get_window_size" c_getWindowSize :: Fd -> IO CLong

getWindowSize :: Fd -> IO (Int,Int)
getWindowSize :: Fd -> IO (Int, Int)
getWindowSize Fd
fd = do
    (CLong
a,CLong
b) <- (CLong -> CLong -> (CLong, CLong)
forall a. Integral a => a -> a -> (a, a)
`divMod` CLong
65536) (CLong -> (CLong, CLong)) -> IO CLong -> IO (CLong, CLong)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Fd -> IO CLong
c_getWindowSize Fd
fd
    (Int, Int) -> IO (Int, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (CLong -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CLong
b, CLong -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CLong
a)

foreign import ccall "gwinsz.h vty_c_set_window_size" c_setWindowSize :: Fd -> CLong -> IO ()

setWindowSize :: Fd -> (Int, Int) -> IO ()
setWindowSize :: Fd -> (Int, Int) -> IO ()
setWindowSize Fd
fd (Int
w, Int
h) = do
    let val :: Int
val = (Int
h Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL` Int
16) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
w
    Fd -> CLong -> IO ()
c_setWindowSize Fd
fd (CLong -> IO ()) -> CLong -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> CLong
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
val

terminfoDisplayContext :: Output -> TerminfoCaps -> DisplayRegion -> IO DisplayContext
terminfoDisplayContext :: Output -> TerminfoCaps -> (Int, Int) -> IO DisplayContext
terminfoDisplayContext Output
tActual TerminfoCaps
terminfoCaps (Int, Int)
r = DisplayContext -> IO DisplayContext
forall (m :: * -> *) a. Monad m => a -> m a
return DisplayContext
dc
    where dc :: DisplayContext
dc = DisplayContext :: Output
-> (Int, Int)
-> (Int -> Int -> Write)
-> Write
-> Write
-> (Bool -> FixedAttr -> Attr -> DisplayAttrDiff -> Write)
-> (Bool -> Write)
-> Write
-> IO ()
-> DisplayContext
DisplayContext
            { contextDevice :: Output
contextDevice = Output
tActual
            , contextRegion :: (Int, Int)
contextRegion = (Int, Int)
r
            , writeMoveCursor :: Int -> Int -> Write
writeMoveCursor = \Int
x Int
y -> CapExpression -> [CapParam] -> Write
writeCapExpr (TerminfoCaps -> CapExpression
cup TerminfoCaps
terminfoCaps) [Int -> CapParam
forall a. Enum a => Int -> a
toEnum Int
y, Int -> CapParam
forall a. Enum a => Int -> a
toEnum Int
x]
            , writeShowCursor :: Write
writeShowCursor = case TerminfoCaps -> Maybe CapExpression
cnorm TerminfoCaps
terminfoCaps of
                Maybe CapExpression
Nothing -> String -> Write
forall a. HasCallStack => String -> a
error String
"this terminal does not support show cursor"
                Just CapExpression
c -> CapExpression -> [CapParam] -> Write
writeCapExpr CapExpression
c []
            , writeHideCursor :: Write
writeHideCursor = case TerminfoCaps -> Maybe CapExpression
civis TerminfoCaps
terminfoCaps of
                Maybe CapExpression
Nothing -> String -> Write
forall a. HasCallStack => String -> a
error String
"this terminal does not support hide cursor"
                Just CapExpression
c -> CapExpression -> [CapParam] -> Write
writeCapExpr CapExpression
c []
            , writeSetAttr :: Bool -> FixedAttr -> Attr -> DisplayAttrDiff -> Write
writeSetAttr = DisplayContext
-> TerminfoCaps
-> Bool
-> FixedAttr
-> Attr
-> DisplayAttrDiff
-> Write
terminfoWriteSetAttr DisplayContext
dc TerminfoCaps
terminfoCaps
            , writeDefaultAttr :: Bool -> Write
writeDefaultAttr = \Bool
urlsEnabled ->
                CapExpression -> [CapParam] -> Write
writeCapExpr (TerminfoCaps -> CapExpression
setDefaultAttr TerminfoCaps
terminfoCaps) [] Write -> Write -> Write
forall a. Monoid a => a -> a -> a
`mappend`
                (if Bool
urlsEnabled then URLDiff -> Write
writeURLEscapes URLDiff
EndLink else Write
forall a. Monoid a => a
mempty) Write -> Write -> Write
forall a. Monoid a => a -> a -> a
`mappend`
                (case DisplayAttrCaps -> Maybe CapExpression
exitStrikethrough (DisplayAttrCaps -> Maybe CapExpression)
-> DisplayAttrCaps -> Maybe CapExpression
forall a b. (a -> b) -> a -> b
$ TerminfoCaps -> DisplayAttrCaps
displayAttrCaps TerminfoCaps
terminfoCaps of
                    Just CapExpression
cap -> CapExpression -> [CapParam] -> Write
writeCapExpr CapExpression
cap []
                    Maybe CapExpression
Nothing -> Write
forall a. Monoid a => a
mempty
                )
            , writeRowEnd :: Write
writeRowEnd = CapExpression -> [CapParam] -> Write
writeCapExpr (TerminfoCaps -> CapExpression
clearEol TerminfoCaps
terminfoCaps) []
            , inlineHack :: IO ()
inlineHack = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            }

-- | Write the escape sequences that are used in some terminals to
-- include embedded hyperlinks. As of yet, this information isn't
-- included in termcap or terminfo, so this writes them directly
-- instead of looking up the appropriate capabilities.
writeURLEscapes :: URLDiff -> Write
writeURLEscapes :: URLDiff -> Write
writeURLEscapes (LinkTo ByteString
url) =
    (Word8 -> Write) -> [Word8] -> Write
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Word8 -> Write
forall a. Storable a => a -> Write
writeStorable (ByteString -> [Word8]
BS.unpack ByteString
"\x1b]8;;") Write -> Write -> Write
forall a. Monoid a => a -> a -> a
`mappend`
    (Word8 -> Write) -> [Word8] -> Write
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Word8 -> Write
forall a. Storable a => a -> Write
writeStorable (ByteString -> [Word8]
BS.unpack ByteString
url) Write -> Write -> Write
forall a. Monoid a => a -> a -> a
`mappend`
    Word8 -> Write
forall a. Storable a => a -> Write
writeStorable (Word8
0x07 :: Word8)
writeURLEscapes URLDiff
EndLink =
    (Word8 -> Write) -> [Word8] -> Write
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Word8 -> Write
forall a. Storable a => a -> Write
writeStorable (ByteString -> [Word8]
BS.unpack ByteString
"\x1b]8;;\a")
writeURLEscapes URLDiff
NoLinkChange =
    Write
forall a. Monoid a => a
mempty

-- | Portably setting the display attributes is a giant pain in the ass.
--
-- If the terminal supports the sgr capability (which sets the on/off
-- state of each style directly ; and, for no good reason, resets the
-- colors to the default) this procedure is used:
--
--  0. set the style attributes. This resets the fore and back color.
--
--  1, If a foreground color is to be set then set the foreground color
--
--  2. likewise with the background color
--
-- If the terminal does not support the sgr cap then: if there is a
-- change from an applied color to the default (in either the fore or
-- back color) then:
--
--  0. reset all display attributes (sgr0)
--
--  1. enter required style modes
--
--  2. set the fore color if required
--
--  3. set the back color if required
--
-- Entering the required style modes could require a reset of the
-- display attributes. If this is the case then the back and fore colors
-- always need to be set if not default.
--
-- This equation implements the above logic.
--
-- Note that this assumes the removal of color changes in the
-- display attributes is done as expected with noColors == True. See
-- `limitAttrForDisplay`.
--
-- Note that this optimizes for fewer state changes followed by fewer
-- bytes.
terminfoWriteSetAttr :: DisplayContext -> TerminfoCaps -> Bool -> FixedAttr -> Attr -> DisplayAttrDiff -> Write
terminfoWriteSetAttr :: DisplayContext
-> TerminfoCaps
-> Bool
-> FixedAttr
-> Attr
-> DisplayAttrDiff
-> Write
terminfoWriteSetAttr DisplayContext
dc TerminfoCaps
terminfoCaps Bool
urlsEnabled FixedAttr
prevAttr Attr
reqAttr DisplayAttrDiff
diffs =
    Bool -> Write
urlAttrs Bool
urlsEnabled Write -> Write -> Write
forall a. Monoid a => a -> a -> a
`mappend` case (DisplayAttrDiff -> DisplayColorDiff
foreColorDiff DisplayAttrDiff
diffs DisplayColorDiff -> DisplayColorDiff -> Bool
forall a. Eq a => a -> a -> Bool
== DisplayColorDiff
ColorToDefault) Bool -> Bool -> Bool
|| (DisplayAttrDiff -> DisplayColorDiff
backColorDiff DisplayAttrDiff
diffs DisplayColorDiff -> DisplayColorDiff -> Bool
forall a. Eq a => a -> a -> Bool
== DisplayColorDiff
ColorToDefault) of
        -- The only way to reset either color, portably, to the default
        -- is to use either the set state capability or the set default
        -- capability.
        Bool
True  -> do
            case DisplayAttrCaps -> Word8 -> [StyleStateChange] -> DisplayAttrSeq
reqDisplayCapSeqFor (TerminfoCaps -> DisplayAttrCaps
displayAttrCaps TerminfoCaps
terminfoCaps)
                                     (FixedAttr -> Word8
fixedStyle FixedAttr
attr )
                                     (Word8 -> [StyleStateChange]
styleToApplySeq (Word8 -> [StyleStateChange]) -> Word8 -> [StyleStateChange]
forall a b. (a -> b) -> a -> b
$ FixedAttr -> Word8
fixedStyle FixedAttr
attr) of
                -- only way to reset a color to the defaults
                EnterExitSeq [CapExpression]
caps -> DisplayContext -> Bool -> Write
writeDefaultAttr DisplayContext
dc Bool
urlsEnabled
                                     Write -> Write -> Write
forall a. Monoid a => a -> a -> a
`mappend`
                                     (CapExpression -> Write) -> [CapExpression] -> Write
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\CapExpression
cap -> CapExpression -> [CapParam] -> Write
writeCapExpr CapExpression
cap []) [CapExpression]
caps
                                     Write -> Write -> Write
forall a. Monoid a => a -> a -> a
`mappend`
                                     Write
setColors
                -- implicitly resets the colors to the defaults
                SetState DisplayAttrState
state -> CapExpression -> [CapParam] -> Write
writeCapExpr (Maybe CapExpression -> CapExpression
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe CapExpression -> CapExpression)
-> Maybe CapExpression -> CapExpression
forall a b. (a -> b) -> a -> b
$ DisplayAttrCaps -> Maybe CapExpression
setAttrStates
                                                         (DisplayAttrCaps -> Maybe CapExpression)
-> DisplayAttrCaps -> Maybe CapExpression
forall a b. (a -> b) -> a -> b
$ TerminfoCaps -> DisplayAttrCaps
displayAttrCaps TerminfoCaps
terminfoCaps
                                               )
                                               (DisplayAttrState -> [CapParam]
sgrArgsForState DisplayAttrState
state)
                                  Write -> Write -> Write
forall a. Monoid a => a -> a -> a
`mappend` Write
setItalics
                                  Write -> Write -> Write
forall a. Monoid a => a -> a -> a
`mappend` Write
setStrikethrough
                                  Write -> Write -> Write
forall a. Monoid a => a -> a -> a
`mappend` Write
setColors
        -- Otherwise the display colors are not changing or changing
        -- between two non-default points.
        Bool
False -> do
            -- Still, it could be the case that the change in display
            -- attributes requires the colors to be reset because the
            -- required capability was not available.
            case DisplayAttrCaps -> Word8 -> [StyleStateChange] -> DisplayAttrSeq
reqDisplayCapSeqFor (TerminfoCaps -> DisplayAttrCaps
displayAttrCaps TerminfoCaps
terminfoCaps)
                                     (FixedAttr -> Word8
fixedStyle FixedAttr
attr)
                                     (DisplayAttrDiff -> [StyleStateChange]
styleDiffs DisplayAttrDiff
diffs) of
                -- Really, if terminals were re-implemented with modern
                -- concepts instead of bowing down to 40 yr old dumb
                -- terminal requirements this would be the only case
                -- ever reached! Changes the style and color states
                -- according to the differences with the currently
                -- applied states.
                EnterExitSeq [CapExpression]
caps -> (CapExpression -> Write) -> [CapExpression] -> Write
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\CapExpression
cap -> CapExpression -> [CapParam] -> Write
writeCapExpr CapExpression
cap []) [CapExpression]
caps
                                     Write -> Write -> Write
forall a. Monoid a => a -> a -> a
`mappend`
                                     (TerminfoCaps -> CapExpression) -> DisplayColorDiff -> Write
writeColorDiff TerminfoCaps -> CapExpression
setForeColor (DisplayAttrDiff -> DisplayColorDiff
foreColorDiff DisplayAttrDiff
diffs)
                                     Write -> Write -> Write
forall a. Monoid a => a -> a -> a
`mappend`
                                     (TerminfoCaps -> CapExpression) -> DisplayColorDiff -> Write
writeColorDiff TerminfoCaps -> CapExpression
setBackColor (DisplayAttrDiff -> DisplayColorDiff
backColorDiff DisplayAttrDiff
diffs)
                -- implicitly resets the colors to the defaults
                SetState DisplayAttrState
state -> CapExpression -> [CapParam] -> Write
writeCapExpr (Maybe CapExpression -> CapExpression
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe CapExpression -> CapExpression)
-> Maybe CapExpression -> CapExpression
forall a b. (a -> b) -> a -> b
$ DisplayAttrCaps -> Maybe CapExpression
setAttrStates
                                                         (DisplayAttrCaps -> Maybe CapExpression)
-> DisplayAttrCaps -> Maybe CapExpression
forall a b. (a -> b) -> a -> b
$ TerminfoCaps -> DisplayAttrCaps
displayAttrCaps TerminfoCaps
terminfoCaps
                                               )
                                               (DisplayAttrState -> [CapParam]
sgrArgsForState DisplayAttrState
state)
                                  Write -> Write -> Write
forall a. Monoid a => a -> a -> a
`mappend` Write
setItalics
                                  Write -> Write -> Write
forall a. Monoid a => a -> a -> a
`mappend` Write
setStrikethrough
                                  Write -> Write -> Write
forall a. Monoid a => a -> a -> a
`mappend` Write
setColors
    where
        urlAttrs :: Bool -> Write
urlAttrs Bool
True = URLDiff -> Write
writeURLEscapes (DisplayAttrDiff -> URLDiff
urlDiff DisplayAttrDiff
diffs)
        urlAttrs Bool
False = Write
forall a. Monoid a => a
mempty
        colorMap :: Color -> Int
colorMap = case TerminfoCaps -> Bool
useAltColorMap TerminfoCaps
terminfoCaps of
                        Bool
False -> Color -> Int
ansiColorIndex
                        Bool
True -> Color -> Int
altColorIndex
        attr :: FixedAttr
attr = FixedAttr -> Attr -> FixedAttr
fixDisplayAttr FixedAttr
prevAttr Attr
reqAttr

        -- italics can't be set via SGR, so here we manually
        -- apply the enter and exit sequences as needed after
        -- changing the SGR
        setItalics :: Write
setItalics
          | Word8 -> Word8 -> Bool
hasStyle (FixedAttr -> Word8
fixedStyle FixedAttr
attr) Word8
italic
          , Just CapExpression
sitm <- DisplayAttrCaps -> Maybe CapExpression
enterItalic (TerminfoCaps -> DisplayAttrCaps
displayAttrCaps TerminfoCaps
terminfoCaps)
          = CapExpression -> [CapParam] -> Write
writeCapExpr CapExpression
sitm []
          | Bool
otherwise = Write
forall a. Monoid a => a
mempty
        setStrikethrough :: Write
setStrikethrough
          | Word8 -> Word8 -> Bool
hasStyle (FixedAttr -> Word8
fixedStyle FixedAttr
attr) Word8
strikethrough
          , Just CapExpression
smxx <- DisplayAttrCaps -> Maybe CapExpression
enterStrikethrough (TerminfoCaps -> DisplayAttrCaps
displayAttrCaps TerminfoCaps
terminfoCaps)
          = CapExpression -> [CapParam] -> Write
writeCapExpr CapExpression
smxx []
          | Bool
otherwise = Write
forall a. Monoid a => a
mempty
        setColors :: Write
setColors =
            (case FixedAttr -> Maybe Color
fixedForeColor FixedAttr
attr of
                Just Color
c -> CapExpression -> [CapParam] -> Write
writeCapExpr (TerminfoCaps -> CapExpression
setForeColor TerminfoCaps
terminfoCaps)
                                       [Int -> CapParam
forall a. Enum a => Int -> a
toEnum (Int -> CapParam) -> Int -> CapParam
forall a b. (a -> b) -> a -> b
$ Color -> Int
colorMap Color
c]
                Maybe Color
Nothing -> Write
forall a. Monoid a => a
mempty)
            Write -> Write -> Write
forall a. Monoid a => a -> a -> a
`mappend`
            (case FixedAttr -> Maybe Color
fixedBackColor FixedAttr
attr of
                Just Color
c -> CapExpression -> [CapParam] -> Write
writeCapExpr (TerminfoCaps -> CapExpression
setBackColor TerminfoCaps
terminfoCaps)
                                       [Int -> CapParam
forall a. Enum a => Int -> a
toEnum (Int -> CapParam) -> Int -> CapParam
forall a b. (a -> b) -> a -> b
$ Color -> Int
colorMap Color
c]
                Maybe Color
Nothing -> Write
forall a. Monoid a => a
mempty)
        writeColorDiff :: (TerminfoCaps -> CapExpression) -> DisplayColorDiff -> Write
writeColorDiff TerminfoCaps -> CapExpression
_f DisplayColorDiff
NoColorChange
            = Write
forall a. Monoid a => a
mempty
        writeColorDiff TerminfoCaps -> CapExpression
_f DisplayColorDiff
ColorToDefault
            = String -> Write
forall a. HasCallStack => String -> a
error String
"ColorToDefault is not a possible case for applyColorDiffs"
        writeColorDiff TerminfoCaps -> CapExpression
f (SetColor Color
c)
            = CapExpression -> [CapParam] -> Write
writeCapExpr (TerminfoCaps -> CapExpression
f TerminfoCaps
terminfoCaps) [Int -> CapParam
forall a. Enum a => Int -> a
toEnum (Int -> CapParam) -> Int -> CapParam
forall a b. (a -> b) -> a -> b
$ Color -> Int
colorMap Color
c]

-- | The color table used by a terminal is a 16 color set followed by a
-- 240 color set that might not be supported by the terminal.
--
-- This takes a Color which clearly identifies which pallete to use and
-- computes the index into the full 256 color pallete.
ansiColorIndex :: Color -> Int
ansiColorIndex :: Color -> Int
ansiColorIndex (ISOColor Word8
v) = Word8 -> Int
forall a. Enum a => a -> Int
fromEnum Word8
v
ansiColorIndex (Color240 Word8
v) = Int
16 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Word8 -> Int
forall a. Enum a => a -> Int
fromEnum Word8
v

-- | For terminals without setaf/setab
--
-- See table in `man terminfo`
-- Will error if not in table.
altColorIndex :: Color -> Int
altColorIndex :: Color -> Int
altColorIndex (ISOColor Word8
0) = Int
0
altColorIndex (ISOColor Word8
1) = Int
4
altColorIndex (ISOColor Word8
2) = Int
2
altColorIndex (ISOColor Word8
3) = Int
6
altColorIndex (ISOColor Word8
4) = Int
1
altColorIndex (ISOColor Word8
5) = Int
5
altColorIndex (ISOColor Word8
6) = Int
3
altColorIndex (ISOColor Word8
7) = Int
7
altColorIndex (ISOColor Word8
v) = Word8 -> Int
forall a. Enum a => a -> Int
fromEnum Word8
v
altColorIndex (Color240 Word8
v) = Int
16 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Word8 -> Int
forall a. Enum a => a -> Int
fromEnum Word8
v

{- | The sequence of terminfo caps to apply a given style are determined
 - according to these rules.
 -
 -  1. The assumption is that it's preferable to use the simpler
 -  enter/exit mode capabilities than the full set display attribute
 -  state capability.
 -
 -  2. If a mode is supposed to be removed but there is not an exit
 -  capability defined then the display attributes are reset to defaults
 -  then the display attribute state is set.
 -
 -  3. If a mode is supposed to be applied but there is not an enter
 -  capability defined then then display attribute state is set if
 -  possible. Otherwise the mode is not applied.
 -
 -  4. If the display attribute state is being set then just update the
 -  arguments to that for any apply/remove.
 -}
data DisplayAttrSeq
    = EnterExitSeq [CapExpression]
    | SetState DisplayAttrState

data DisplayAttrState = DisplayAttrState
    { DisplayAttrState -> Bool
applyStandout :: Bool
    , DisplayAttrState -> Bool
applyUnderline :: Bool
    , DisplayAttrState -> Bool
applyItalic :: Bool
    , DisplayAttrState -> Bool
applyStrikethrough :: Bool
    , DisplayAttrState -> Bool
applyReverseVideo :: Bool
    , DisplayAttrState -> Bool
applyBlink :: Bool
    , DisplayAttrState -> Bool
applyDim :: Bool
    , DisplayAttrState -> Bool
applyBold :: Bool
    }

sgrArgsForState :: DisplayAttrState -> [CapParam]
sgrArgsForState :: DisplayAttrState -> [CapParam]
sgrArgsForState DisplayAttrState
attrState = (Bool -> CapParam) -> [Bool] -> [CapParam]
forall a b. (a -> b) -> [a] -> [b]
map (\Bool
b -> if Bool
b then CapParam
1 else CapParam
0)
    [ DisplayAttrState -> Bool
applyStandout DisplayAttrState
attrState
    , DisplayAttrState -> Bool
applyUnderline DisplayAttrState
attrState
    , DisplayAttrState -> Bool
applyReverseVideo DisplayAttrState
attrState
    , DisplayAttrState -> Bool
applyBlink DisplayAttrState
attrState
    , DisplayAttrState -> Bool
applyDim DisplayAttrState
attrState
    , DisplayAttrState -> Bool
applyBold DisplayAttrState
attrState
    , Bool
False -- invis
    , Bool
False -- protect
    , Bool
False -- alt char set
    ]

reqDisplayCapSeqFor :: DisplayAttrCaps -> Style -> [StyleStateChange] -> DisplayAttrSeq
reqDisplayCapSeqFor :: DisplayAttrCaps -> Word8 -> [StyleStateChange] -> DisplayAttrSeq
reqDisplayCapSeqFor DisplayAttrCaps
caps Word8
s [StyleStateChange]
diffs
    -- if the state transition implied by any diff cannot be supported
    -- with an enter/exit mode cap then either the state needs to be set
    -- or the attribute change ignored.
    = case ((StyleStateChange -> Bool) -> [StyleStateChange] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any StyleStateChange -> Bool
noEnterExitCap [StyleStateChange]
diffs, Maybe CapExpression -> Bool
forall a. Maybe a -> Bool
isJust (Maybe CapExpression -> Bool) -> Maybe CapExpression -> Bool
forall a b. (a -> b) -> a -> b
$ DisplayAttrCaps -> Maybe CapExpression
setAttrStates DisplayAttrCaps
caps) of
        -- If all the diffs have an enter-exit cap then just use those
        ( Bool
False, Bool
_    ) -> [CapExpression] -> DisplayAttrSeq
EnterExitSeq ([CapExpression] -> DisplayAttrSeq)
-> [CapExpression] -> DisplayAttrSeq
forall a b. (a -> b) -> a -> b
$ (StyleStateChange -> CapExpression)
-> [StyleStateChange] -> [CapExpression]
forall a b. (a -> b) -> [a] -> [b]
map StyleStateChange -> CapExpression
enterExitCap [StyleStateChange]
diffs
        -- If not all the diffs have an enter-exit cap and there is no
        -- set state cap then filter out all unsupported diffs and just
        -- apply the rest
        ( Bool
True, Bool
False ) -> [CapExpression] -> DisplayAttrSeq
EnterExitSeq ([CapExpression] -> DisplayAttrSeq)
-> [CapExpression] -> DisplayAttrSeq
forall a b. (a -> b) -> a -> b
$ (StyleStateChange -> CapExpression)
-> [StyleStateChange] -> [CapExpression]
forall a b. (a -> b) -> [a] -> [b]
map StyleStateChange -> CapExpression
enterExitCap
                                        ([StyleStateChange] -> [CapExpression])
-> [StyleStateChange] -> [CapExpression]
forall a b. (a -> b) -> a -> b
$ (StyleStateChange -> Bool)
-> [StyleStateChange] -> [StyleStateChange]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> (StyleStateChange -> Bool) -> StyleStateChange -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StyleStateChange -> Bool
noEnterExitCap) [StyleStateChange]
diffs
        -- if not all the diffs have an enter-exit can and there is a
        -- set state cap then just use the set state cap.
        ( Bool
True, Bool
True  ) -> DisplayAttrState -> DisplayAttrSeq
SetState (DisplayAttrState -> DisplayAttrSeq)
-> DisplayAttrState -> DisplayAttrSeq
forall a b. (a -> b) -> a -> b
$ Word8 -> DisplayAttrState
stateForStyle Word8
s
    where
        noEnterExitCap :: StyleStateChange -> Bool
noEnterExitCap StyleStateChange
ApplyStrikethrough = Maybe CapExpression -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe CapExpression -> Bool) -> Maybe CapExpression -> Bool
forall a b. (a -> b) -> a -> b
$ DisplayAttrCaps -> Maybe CapExpression
enterStrikethrough DisplayAttrCaps
caps
        noEnterExitCap StyleStateChange
RemoveStrikethrough = Maybe CapExpression -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe CapExpression -> Bool) -> Maybe CapExpression -> Bool
forall a b. (a -> b) -> a -> b
$ DisplayAttrCaps -> Maybe CapExpression
exitStrikethrough DisplayAttrCaps
caps
        noEnterExitCap StyleStateChange
ApplyItalic = Maybe CapExpression -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe CapExpression -> Bool) -> Maybe CapExpression -> Bool
forall a b. (a -> b) -> a -> b
$ DisplayAttrCaps -> Maybe CapExpression
enterItalic DisplayAttrCaps
caps
        noEnterExitCap StyleStateChange
RemoveItalic = Maybe CapExpression -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe CapExpression -> Bool) -> Maybe CapExpression -> Bool
forall a b. (a -> b) -> a -> b
$ DisplayAttrCaps -> Maybe CapExpression
exitItalic DisplayAttrCaps
caps
        noEnterExitCap StyleStateChange
ApplyStandout = Maybe CapExpression -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe CapExpression -> Bool) -> Maybe CapExpression -> Bool
forall a b. (a -> b) -> a -> b
$ DisplayAttrCaps -> Maybe CapExpression
enterStandout DisplayAttrCaps
caps
        noEnterExitCap StyleStateChange
RemoveStandout = Maybe CapExpression -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe CapExpression -> Bool) -> Maybe CapExpression -> Bool
forall a b. (a -> b) -> a -> b
$ DisplayAttrCaps -> Maybe CapExpression
exitStandout DisplayAttrCaps
caps
        noEnterExitCap StyleStateChange
ApplyUnderline = Maybe CapExpression -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe CapExpression -> Bool) -> Maybe CapExpression -> Bool
forall a b. (a -> b) -> a -> b
$ DisplayAttrCaps -> Maybe CapExpression
enterUnderline DisplayAttrCaps
caps
        noEnterExitCap StyleStateChange
RemoveUnderline = Maybe CapExpression -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe CapExpression -> Bool) -> Maybe CapExpression -> Bool
forall a b. (a -> b) -> a -> b
$ DisplayAttrCaps -> Maybe CapExpression
exitUnderline DisplayAttrCaps
caps
        noEnterExitCap StyleStateChange
ApplyReverseVideo = Maybe CapExpression -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe CapExpression -> Bool) -> Maybe CapExpression -> Bool
forall a b. (a -> b) -> a -> b
$ DisplayAttrCaps -> Maybe CapExpression
enterReverseVideo DisplayAttrCaps
caps
        noEnterExitCap StyleStateChange
RemoveReverseVideo = Bool
True
        noEnterExitCap StyleStateChange
ApplyBlink = Bool
True
        noEnterExitCap StyleStateChange
RemoveBlink = Bool
True
        noEnterExitCap StyleStateChange
ApplyDim = Maybe CapExpression -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe CapExpression -> Bool) -> Maybe CapExpression -> Bool
forall a b. (a -> b) -> a -> b
$ DisplayAttrCaps -> Maybe CapExpression
enterDimMode DisplayAttrCaps
caps
        noEnterExitCap StyleStateChange
RemoveDim = Bool
True
        noEnterExitCap StyleStateChange
ApplyBold = Maybe CapExpression -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe CapExpression -> Bool) -> Maybe CapExpression -> Bool
forall a b. (a -> b) -> a -> b
$ DisplayAttrCaps -> Maybe CapExpression
enterBoldMode DisplayAttrCaps
caps
        noEnterExitCap StyleStateChange
RemoveBold = Bool
True
        enterExitCap :: StyleStateChange -> CapExpression
enterExitCap StyleStateChange
ApplyStrikethrough = Maybe CapExpression -> CapExpression
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe CapExpression -> CapExpression)
-> Maybe CapExpression -> CapExpression
forall a b. (a -> b) -> a -> b
$ DisplayAttrCaps -> Maybe CapExpression
enterStrikethrough DisplayAttrCaps
caps
        enterExitCap StyleStateChange
RemoveStrikethrough = Maybe CapExpression -> CapExpression
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe CapExpression -> CapExpression)
-> Maybe CapExpression -> CapExpression
forall a b. (a -> b) -> a -> b
$ DisplayAttrCaps -> Maybe CapExpression
exitStrikethrough DisplayAttrCaps
caps
        enterExitCap StyleStateChange
ApplyItalic = Maybe CapExpression -> CapExpression
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe CapExpression -> CapExpression)
-> Maybe CapExpression -> CapExpression
forall a b. (a -> b) -> a -> b
$ DisplayAttrCaps -> Maybe CapExpression
enterItalic DisplayAttrCaps
caps
        enterExitCap StyleStateChange
RemoveItalic = Maybe CapExpression -> CapExpression
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe CapExpression -> CapExpression)
-> Maybe CapExpression -> CapExpression
forall a b. (a -> b) -> a -> b
$ DisplayAttrCaps -> Maybe CapExpression
exitItalic DisplayAttrCaps
caps
        enterExitCap StyleStateChange
ApplyStandout = Maybe CapExpression -> CapExpression
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe CapExpression -> CapExpression)
-> Maybe CapExpression -> CapExpression
forall a b. (a -> b) -> a -> b
$ DisplayAttrCaps -> Maybe CapExpression
enterStandout DisplayAttrCaps
caps
        enterExitCap StyleStateChange
RemoveStandout = Maybe CapExpression -> CapExpression
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe CapExpression -> CapExpression)
-> Maybe CapExpression -> CapExpression
forall a b. (a -> b) -> a -> b
$ DisplayAttrCaps -> Maybe CapExpression
exitStandout DisplayAttrCaps
caps
        enterExitCap StyleStateChange
ApplyUnderline = Maybe CapExpression -> CapExpression
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe CapExpression -> CapExpression)
-> Maybe CapExpression -> CapExpression
forall a b. (a -> b) -> a -> b
$ DisplayAttrCaps -> Maybe CapExpression
enterUnderline DisplayAttrCaps
caps
        enterExitCap StyleStateChange
RemoveUnderline = Maybe CapExpression -> CapExpression
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe CapExpression -> CapExpression)
-> Maybe CapExpression -> CapExpression
forall a b. (a -> b) -> a -> b
$ DisplayAttrCaps -> Maybe CapExpression
exitUnderline DisplayAttrCaps
caps
        enterExitCap StyleStateChange
ApplyReverseVideo = Maybe CapExpression -> CapExpression
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe CapExpression -> CapExpression)
-> Maybe CapExpression -> CapExpression
forall a b. (a -> b) -> a -> b
$ DisplayAttrCaps -> Maybe CapExpression
enterReverseVideo DisplayAttrCaps
caps
        enterExitCap StyleStateChange
ApplyDim = Maybe CapExpression -> CapExpression
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe CapExpression -> CapExpression)
-> Maybe CapExpression -> CapExpression
forall a b. (a -> b) -> a -> b
$ DisplayAttrCaps -> Maybe CapExpression
enterDimMode DisplayAttrCaps
caps
        enterExitCap StyleStateChange
ApplyBold = Maybe CapExpression -> CapExpression
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe CapExpression -> CapExpression)
-> Maybe CapExpression -> CapExpression
forall a b. (a -> b) -> a -> b
$ DisplayAttrCaps -> Maybe CapExpression
enterBoldMode DisplayAttrCaps
caps
        enterExitCap StyleStateChange
_ = String -> CapExpression
forall a. HasCallStack => String -> a
error String
"enterExitCap applied to diff that was known not to have one."

stateForStyle :: Style -> DisplayAttrState
stateForStyle :: Word8 -> DisplayAttrState
stateForStyle Word8
s = DisplayAttrState :: Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> DisplayAttrState
DisplayAttrState
    { applyStandout :: Bool
applyStandout = Word8 -> Bool
isStyleSet Word8
standout
    , applyUnderline :: Bool
applyUnderline = Word8 -> Bool
isStyleSet Word8
underline
    , applyItalic :: Bool
applyItalic = Word8 -> Bool
isStyleSet Word8
italic
    , applyStrikethrough :: Bool
applyStrikethrough = Word8 -> Bool
isStyleSet Word8
strikethrough
    , applyReverseVideo :: Bool
applyReverseVideo = Word8 -> Bool
isStyleSet Word8
reverseVideo
    , applyBlink :: Bool
applyBlink = Word8 -> Bool
isStyleSet Word8
blink
    , applyDim :: Bool
applyDim = Word8 -> Bool
isStyleSet Word8
dim
    , applyBold :: Bool
applyBold = Word8 -> Bool
isStyleSet Word8
bold
    }
    where isStyleSet :: Word8 -> Bool
isStyleSet = Word8 -> Word8 -> Bool
hasStyle Word8
s

styleToApplySeq :: Style -> [StyleStateChange]
styleToApplySeq :: Word8 -> [StyleStateChange]
styleToApplySeq Word8
s = [[StyleStateChange]] -> [StyleStateChange]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ StyleStateChange -> Word8 -> [StyleStateChange]
forall a. a -> Word8 -> [a]
applyIfRequired StyleStateChange
ApplyStandout Word8
standout
    , StyleStateChange -> Word8 -> [StyleStateChange]
forall a. a -> Word8 -> [a]
applyIfRequired StyleStateChange
ApplyUnderline Word8
underline
    , StyleStateChange -> Word8 -> [StyleStateChange]
forall a. a -> Word8 -> [a]
applyIfRequired StyleStateChange
ApplyItalic Word8
italic
    , StyleStateChange -> Word8 -> [StyleStateChange]
forall a. a -> Word8 -> [a]
applyIfRequired StyleStateChange
ApplyStrikethrough Word8
strikethrough
    , StyleStateChange -> Word8 -> [StyleStateChange]
forall a. a -> Word8 -> [a]
applyIfRequired StyleStateChange
ApplyReverseVideo Word8
reverseVideo
    , StyleStateChange -> Word8 -> [StyleStateChange]
forall a. a -> Word8 -> [a]
applyIfRequired StyleStateChange
ApplyBlink Word8
blink
    , StyleStateChange -> Word8 -> [StyleStateChange]
forall a. a -> Word8 -> [a]
applyIfRequired StyleStateChange
ApplyDim Word8
dim
    , StyleStateChange -> Word8 -> [StyleStateChange]
forall a. a -> Word8 -> [a]
applyIfRequired StyleStateChange
ApplyBold Word8
bold
    ]
    where
        applyIfRequired :: a -> Word8 -> [a]
applyIfRequired a
op Word8
flag
            = if Word8
0 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== (Word8
flag Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
s)
                then []
                else [a
op]