{-# 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, writeWord8)

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
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 forall a. Ord a => a -> a -> Bool
<  Int
0  = forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"fdWriteAll: len is less than 0"
    | Int
len forall a. Eq a => a -> a -> Bool
== Int
0  = forall (m :: * -> *) a. Monad m => a -> m a
return Int
count
    | Bool
otherwise = do
        Int
writeCount <- forall a. Enum a => a -> Int
fromEnum forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Fd -> Ptr Word8 -> ByteCount -> IO ByteCount
fdWriteBuf Fd
outFd Ptr Word8
ptr (forall a. Enum a => Int -> a
toEnum Int
len)
        let len' :: Int
len' = Int
len forall a. Num a => a -> a -> a
- Int
writeCount
            ptr' :: Ptr b
ptr' = Ptr Word8
ptr forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
writeCount
            count' :: Int
count' = Int
count forall a. Num a => a -> a -> a
+ Int
writeCount
        Fd -> Ptr Word8 -> Int -> Int -> IO Int
fdWriteAll Fd
outFd 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 forall a b. (a -> b) -> a -> b
$ Write -> ByteString
writeToByteString 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 -> ColorMode -> IO Output
reserveTerminal :: [Char] -> Fd -> ColorMode -> IO Output
reserveTerminal [Char]
termName Fd
outFd ColorMode
colorMode = do
    Terminal
ti <- [Char] -> IO Terminal
Terminfo.setupTerm [Char]
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 -> [Char] -> IO (Maybe CapExpression)
probeCap Terminal
ti [Char]
"setaf"
    Maybe CapExpression
msetf <- Terminal -> [Char] -> IO (Maybe CapExpression)
probeCap Terminal
ti [Char]
"setf"
    let (Bool
useAlt, CapExpression
setForeCap)
            = case Maybe CapExpression
msetaf of
                Just CapExpression
setaf -> (Bool
False, CapExpression
setaf)
                Maybe CapExpression
Nothing -> case Maybe CapExpression
msetf of
                    Just CapExpression
setf -> (Bool
True, CapExpression
setf)
                    Maybe CapExpression
Nothing -> (Bool
True, forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"no fore color support for terminal " forall a. [a] -> [a] -> [a]
++ [Char]
termName)
    Maybe CapExpression
msetab <- Terminal -> [Char] -> IO (Maybe CapExpression)
probeCap Terminal
ti [Char]
"setab"
    Maybe CapExpression
msetb <- Terminal -> [Char] -> IO (Maybe CapExpression)
probeCap Terminal
ti [Char]
"setb"
    let setBackCap :: CapExpression
setBackCap
            = case Maybe CapExpression
msetab of
                Just CapExpression
setab -> CapExpression
setab
                Maybe CapExpression
Nothing -> case Maybe CapExpression
msetb of
                    Just CapExpression
setb -> CapExpression
setb
                    Maybe CapExpression
Nothing -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"no back color support for terminal " forall a. [a] -> [a] -> [a]
++ [Char]
termName

    IORef Bool
hyperlinkModeStatus <- forall a. a -> IO (IORef a)
newIORef Bool
False
    IORef AssumedState
newAssumedStateRef <- 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
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
newStatus forall a. Eq a => a -> a -> Bool
/= Bool
curStatus) forall a b. (a -> b) -> a -> b
$
              case Mode
m of
                  Mode
Hyperlink -> do
                      forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
hyperlinkModeStatus Bool
newStatus
                      forall a. IORef a -> a -> IO ()
writeIORef IORef AssumedState
newAssumedStateRef AssumedState
initialAssumedState
                  Mode
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        terminfoModeStatus :: Mode -> IO Bool
terminfoModeStatus Mode
m =
            case Mode
m of
                Mode
Hyperlink -> forall a. IORef a -> IO a
readIORef IORef Bool
hyperlinkModeStatus
                Mode
_ -> 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 <- forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe CapExpression
-> Maybe CapExpression
-> CapExpression
-> Maybe CapExpression
-> Maybe CapExpression
-> Bool
-> CapExpression
-> CapExpression
-> CapExpression
-> CapExpression
-> CapExpression
-> DisplayAttrCaps
-> Maybe CapExpression
-> TerminfoCaps
TerminfoCaps
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Terminal -> [Char] -> IO (Maybe CapExpression)
probeCap Terminal
ti [Char]
"smcup"
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Terminal -> [Char] -> IO (Maybe CapExpression)
probeCap Terminal
ti [Char]
"rmcup"
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Terminal -> [Char] -> IO CapExpression
requireCap Terminal
ti [Char]
"cup"
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Terminal -> [Char] -> IO (Maybe CapExpression)
probeCap Terminal
ti [Char]
"cnorm"
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Terminal -> [Char] -> IO (Maybe CapExpression)
probeCap Terminal
ti [Char]
"civis"
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
useAlt
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure CapExpression
setForeCap
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure CapExpression
setBackCap
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Terminal -> [Char] -> IO CapExpression
requireCap Terminal
ti [Char]
"sgr0"
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Terminal -> [Char] -> IO CapExpression
requireCap Terminal
ti [Char]
"clear"
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Terminal -> [Char] -> IO CapExpression
requireCap Terminal
ti [Char]
"el"
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Terminal -> IO DisplayAttrCaps
currentDisplayAttrCaps Terminal
ti
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Terminal -> [Char] -> IO (Maybe CapExpression)
probeCap Terminal
ti [Char]
"bel"
    let t :: Output
t = Output
            { terminalID :: [Char]
terminalID = [Char]
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 = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Maybe a -> Bool
isJust forall a b. (a -> b) -> a -> b
$ TerminfoCaps -> Maybe CapExpression
ringBellAudio TerminfoCaps
terminfoCaps
            , supportsItalics :: IO Bool
supportsItalics = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (forall a. Maybe a -> Bool
isJust forall a b. (a -> b) -> a -> b
$ DisplayAttrCaps -> Maybe CapExpression
enterItalic (TerminfoCaps -> DisplayAttrCaps
displayAttrCaps TerminfoCaps
terminfoCaps)) Bool -> Bool -> Bool
&&
                                         (forall a. Maybe a -> Bool
isJust forall a b. (a -> b) -> a -> b
$ DisplayAttrCaps -> Maybe CapExpression
exitItalic (TerminfoCaps -> DisplayAttrCaps
displayAttrCaps TerminfoCaps
terminfoCaps))
            , supportsStrikethrough :: IO Bool
supportsStrikethrough = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (forall a. Maybe a -> Bool
isJust forall a b. (a -> b) -> a -> b
$ DisplayAttrCaps -> Maybe CapExpression
enterStrikethrough (TerminfoCaps -> DisplayAttrCaps
displayAttrCaps TerminfoCaps
terminfoCaps)) Bool -> Bool -> Bool
&&
                                               (forall a. Maybe a -> Bool
isJust 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 forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| Int
h forall a. Ord a => a -> a -> Bool
< Int
0 -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$ [Char]
"getwinsize returned < 0 : " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (Int, Int)
rawSize
                            | Bool
otherwise      -> 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 <- forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
fptr
                             forall a b. (a -> b) -> a -> b
$ \Ptr Word8
ptr -> Fd -> Ptr Word8 -> Int -> Int -> IO Int
fdWriteAll Fd
outFd (Ptr Word8
ptr forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
offset) Int
len Int
0
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Enum a => Int -> a
toEnum Int
len forall a. Eq a => a -> a -> Bool
/= Int
actualLen) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$ [Char]
"Graphics.Vty.Output: outputByteBuffer "
                  forall a. [a] -> [a] -> [a]
++ [Char]
"length mismatch. " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
len forall a. [a] -> [a] -> [a]
++ [Char]
" /= " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
actualLen
                  forall a. [a] -> [a] -> [a]
++ [Char]
" Please report this bug to vty project."
            , supportsCursorVisibility :: Bool
supportsCursorVisibility = forall a. Maybe a -> Bool
isJust 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
            , outputColorMode :: ColorMode
outputColorMode = ColorMode
colorMode
            -- 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 = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isJust forall a b. (a -> b) -> a -> b
$ TerminfoCaps -> Maybe CapExpression
s TerminfoCaps
terminfoCaps) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TerminfoCaps -> CapExpression) -> [CapParam] -> IO ()
sendCap (forall a. HasCallStack => Maybe a -> a
fromJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. TerminfoCaps -> Maybe CapExpression
s)
    forall (m :: * -> *) a. Monad m => a -> m a
return Output
t

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

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

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

currentDisplayAttrCaps :: Terminfo.Terminal -> IO DisplayAttrCaps
currentDisplayAttrCaps :: Terminal -> IO DisplayAttrCaps
currentDisplayAttrCaps Terminal
ti
    =   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
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Terminal -> [Char] -> IO (Maybe CapExpression)
probeCap Terminal
ti [Char]
"sgr"
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Terminal -> [Char] -> IO (Maybe CapExpression)
probeCap Terminal
ti [Char]
"smso"
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Terminal -> [Char] -> IO (Maybe CapExpression)
probeCap Terminal
ti [Char]
"rmso"
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Terminal -> [Char] -> IO (Maybe CapExpression)
probeCap Terminal
ti [Char]
"sitm"
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Terminal -> [Char] -> IO (Maybe CapExpression)
probeCap Terminal
ti [Char]
"ritm"
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Terminal -> [Char] -> IO (Maybe CapExpression)
probeCap Terminal
ti [Char]
"smxx"
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Terminal -> [Char] -> IO (Maybe CapExpression)
probeCap Terminal
ti [Char]
"rmxx"
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Terminal -> [Char] -> IO (Maybe CapExpression)
probeCap Terminal
ti [Char]
"smul"
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Terminal -> [Char] -> IO (Maybe CapExpression)
probeCap Terminal
ti [Char]
"rmul"
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Terminal -> [Char] -> IO (Maybe CapExpression)
probeCap Terminal
ti [Char]
"rev"
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Terminal -> [Char] -> IO (Maybe CapExpression)
probeCap Terminal
ti [Char]
"dim"
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Terminal -> [Char] -> IO (Maybe CapExpression)
probeCap Terminal
ti [Char]
"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) <- (forall a. Integral a => a -> a -> (a, a)
`divMod` CLong
65536) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Fd -> IO CLong
c_getWindowSize Fd
fd
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. (Integral a, Num b) => a -> b
fromIntegral CLong
b, 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 forall a. Bits a => a -> Int -> a
`shiftL` Int
16) forall a. Num a => a -> a -> a
+ Int
w
    Fd -> CLong -> IO ()
c_setWindowSize Fd
fd forall a b. (a -> b) -> a -> b
$ 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 = forall (m :: * -> *) a. Monad m => a -> m a
return DisplayContext
dc
    where dc :: DisplayContext
dc = 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) [forall a. Enum a => Int -> a
toEnum Int
y, forall a. Enum a => Int -> a
toEnum Int
x]
            , writeShowCursor :: Write
writeShowCursor = case TerminfoCaps -> Maybe CapExpression
cnorm TerminfoCaps
terminfoCaps of
                Maybe CapExpression
Nothing -> forall a. HasCallStack => [Char] -> a
error [Char]
"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 -> forall a. HasCallStack => [Char] -> a
error [Char]
"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) [] forall a. Monoid a => a -> a -> a
`mappend`
                (if Bool
urlsEnabled then URLDiff -> Write
writeURLEscapes URLDiff
EndLink else forall a. Monoid a => a
mempty) forall a. Monoid a => a -> a -> a
`mappend`
                (case DisplayAttrCaps -> Maybe CapExpression
exitStrikethrough 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 -> forall a. Monoid a => a
mempty
                )
            , writeRowEnd :: Write
writeRowEnd = CapExpression -> [CapParam] -> Write
writeCapExpr (TerminfoCaps -> CapExpression
clearEol TerminfoCaps
terminfoCaps) []
            , inlineHack :: IO ()
inlineHack = 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) =
    forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall a. Storable a => a -> Write
writeStorable (ByteString -> [Word8]
BS.unpack ByteString
"\x1b]8;;") forall a. Monoid a => a -> a -> a
`mappend`
    forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall a. Storable a => a -> Write
writeStorable (ByteString -> [Word8]
BS.unpack ByteString
url) forall a. Monoid a => a -> a -> a
`mappend`
    forall a. Storable a => a -> Write
writeStorable (Word8
0x07 :: Word8)
writeURLEscapes URLDiff
EndLink =
    forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall a. Storable a => a -> Write
writeStorable (ByteString -> [Word8]
BS.unpack ByteString
"\x1b]8;;\a")
writeURLEscapes URLDiff
NoLinkChange =
    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 forall a. Monoid a => a -> a -> a
`mappend` case (DisplayAttrDiff -> DisplayColorDiff
foreColorDiff DisplayAttrDiff
diffs forall a. Eq a => a -> a -> Bool
== DisplayColorDiff
ColorToDefault) Bool -> Bool -> Bool
|| (DisplayAttrDiff -> DisplayColorDiff
backColorDiff DisplayAttrDiff
diffs 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 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
                                     forall a. Monoid a => a -> a -> a
`mappend`
                                     forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\CapExpression
cap -> CapExpression -> [CapParam] -> Write
writeCapExpr CapExpression
cap []) [CapExpression]
caps
                                     forall a. Monoid a => a -> a -> a
`mappend`
                                     Write
setColors
                -- implicitly resets the colors to the defaults
                SetState DisplayAttrState
state -> CapExpression -> [CapParam] -> Write
writeCapExpr (forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ DisplayAttrCaps -> Maybe CapExpression
setAttrStates
                                                         forall a b. (a -> b) -> a -> b
$ TerminfoCaps -> DisplayAttrCaps
displayAttrCaps TerminfoCaps
terminfoCaps
                                               )
                                               (DisplayAttrState -> [CapParam]
sgrArgsForState DisplayAttrState
state)
                                  forall a. Monoid a => a -> a -> a
`mappend` Write
setItalics
                                  forall a. Monoid a => a -> a -> a
`mappend` Write
setStrikethrough
                                  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 -> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\CapExpression
cap -> CapExpression -> [CapParam] -> Write
writeCapExpr CapExpression
cap []) [CapExpression]
caps
                                     forall a. Monoid a => a -> a -> a
`mappend`
                                     ColorSide -> DisplayColorDiff -> Write
writeColorDiff ColorSide
Foreground (DisplayAttrDiff -> DisplayColorDiff
foreColorDiff DisplayAttrDiff
diffs)
                                     forall a. Monoid a => a -> a -> a
`mappend`
                                     ColorSide -> DisplayColorDiff -> Write
writeColorDiff ColorSide
Background (DisplayAttrDiff -> DisplayColorDiff
backColorDiff DisplayAttrDiff
diffs)
                -- implicitly resets the colors to the defaults
                SetState DisplayAttrState
state -> CapExpression -> [CapParam] -> Write
writeCapExpr (forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ DisplayAttrCaps -> Maybe CapExpression
setAttrStates
                                                         forall a b. (a -> b) -> a -> b
$ TerminfoCaps -> DisplayAttrCaps
displayAttrCaps TerminfoCaps
terminfoCaps
                                               )
                                               (DisplayAttrState -> [CapParam]
sgrArgsForState DisplayAttrState
state)
                                  forall a. Monoid a => a -> a -> a
`mappend` Write
setItalics
                                  forall a. Monoid a => a -> a -> a
`mappend` Write
setStrikethrough
                                  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 = 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 = 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 = forall a. Monoid a => a
mempty
        setColors :: Write
setColors =
            (case FixedAttr -> Maybe Color
fixedForeColor FixedAttr
attr of
                Just Color
c -> ColorSide -> Color -> Write
writeColor ColorSide
Foreground Color
c
                Maybe Color
Nothing -> forall a. Monoid a => a
mempty)
            forall a. Monoid a => a -> a -> a
`mappend`
            (case FixedAttr -> Maybe Color
fixedBackColor FixedAttr
attr of
                Just Color
c -> ColorSide -> Color -> Write
writeColor ColorSide
Background Color
c
                Maybe Color
Nothing -> forall a. Monoid a => a
mempty)
        writeColorDiff :: ColorSide -> DisplayColorDiff -> Write
writeColorDiff ColorSide
_side DisplayColorDiff
NoColorChange
            = forall a. Monoid a => a
mempty
        writeColorDiff ColorSide
_side DisplayColorDiff
ColorToDefault
            = forall a. HasCallStack => [Char] -> a
error [Char]
"ColorToDefault is not a possible case for applyColorDiffs"
        writeColorDiff ColorSide
side (SetColor Color
c)
            = ColorSide -> Color -> Write
writeColor ColorSide
side Color
c

        writeColor :: ColorSide -> Color -> Write
writeColor ColorSide
side (RGBColor Word8
r Word8
g Word8
b) =
            case Output -> ColorMode
outputColorMode (DisplayContext -> Output
contextDevice DisplayContext
dc) of
                ColorMode
FullColor ->
                    ColorSide -> (Word8, Word8, Word8) -> Write
hardcodeColor ColorSide
side (Word8
r, Word8
g, Word8
b)
                ColorMode
_ ->
                    forall a. HasCallStack => [Char] -> a
error [Char]
"clampColor should remove rgb colors in standard mode"
        writeColor ColorSide
side Color
c =
            CapExpression -> [CapParam] -> Write
writeCapExpr (ColorSide -> TerminfoCaps -> CapExpression
setSideColor ColorSide
side TerminfoCaps
terminfoCaps) [forall a. Enum a => Int -> a
toEnum forall a b. (a -> b) -> a -> b
$ Color -> Int
colorMap Color
c]

-- a color can either be in the foreground or the background
data ColorSide = Foreground | Background

-- get the capability for drawing a color on a specific side
setSideColor :: ColorSide -> TerminfoCaps -> CapExpression
setSideColor :: ColorSide -> TerminfoCaps -> CapExpression
setSideColor ColorSide
Foreground = TerminfoCaps -> CapExpression
setForeColor
setSideColor ColorSide
Background = TerminfoCaps -> CapExpression
setBackColor

hardcodeColor :: ColorSide -> (Word8, Word8, Word8) -> Write
hardcodeColor :: ColorSide -> (Word8, Word8, Word8) -> Write
hardcodeColor ColorSide
side (Word8
r, Word8
g, Word8
b) =
    -- hardcoded color codes are formatted as "\x1b[{side};2;{r};{g};{b}m"
    forall a. Monoid a => [a] -> a
mconcat [ [Char] -> Write
writeStr [Char]
"\x1b[", Write
sideCode, Write
delimiter, Char -> Write
writeChar Char
'2', Write
delimiter
            , Word8 -> Write
writeColor Word8
r, Write
delimiter, Word8 -> Write
writeColor Word8
g, Write
delimiter, Word8 -> Write
writeColor Word8
b
            , Char -> Write
writeChar Char
'm']
    where
        writeChar :: Char -> Write
writeChar = Word8 -> Write
writeWord8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Enum a => a -> Int
fromEnum
        writeStr :: [Char] -> Write
writeStr = forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Char -> Write
writeChar
        writeColor :: Word8 -> Write
writeColor = [Char] -> Write
writeStr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show
        delimiter :: Write
delimiter = Char -> Write
writeChar Char
';'
        -- 38/48 are used to set whether we should write to the
        -- foreground/background. I really don't want to know why.
        sideCode :: Write
sideCode = case ColorSide
side of
            ColorSide
Foreground -> [Char] -> Write
writeStr [Char]
"38"
            ColorSide
Background -> [Char] -> Write
writeStr [Char]
"48"

-- | 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 palette to use and
-- computes the index into the full 256 color palette.
ansiColorIndex :: Color -> Int
ansiColorIndex :: Color -> Int
ansiColorIndex (ISOColor Word8
v) = forall a. Enum a => a -> Int
fromEnum Word8
v
ansiColorIndex (Color240 Word8
v) = Int
16 forall a. Num a => a -> a -> a
+ forall a. Enum a => a -> Int
fromEnum Word8
v
ansiColorIndex (RGBColor Word8
_ Word8
_ Word8
_) =
    forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unlines [ [Char]
"Attempted to create color index from rgb color."
                    , [Char]
"This is currently unsupported, and shouldn't ever happen"
                    ]

-- | 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) = forall a. Enum a => a -> Int
fromEnum Word8
v
altColorIndex (Color240 Word8
v) = Int
16 forall a. Num a => a -> a -> a
+ forall a. Enum a => a -> Int
fromEnum Word8
v
altColorIndex (RGBColor Word8
_ Word8
_ Word8
_) =
    forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unlines [ [Char]
"Attempted to create color index from rgb color."
                    , [Char]
"This is currently unsupported, and shouldn't ever happen"
                    ]

{- | 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 = 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 (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any StyleStateChange -> Bool
noEnterExitCap [StyleStateChange]
diffs, forall a. Maybe a -> Bool
isJust 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 forall a b. (a -> b) -> a -> b
$ 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 forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map StyleStateChange -> CapExpression
enterExitCap
                                        forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not 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 forall a b. (a -> b) -> a -> b
$ Word8 -> DisplayAttrState
stateForStyle Word8
s
    where
        noEnterExitCap :: StyleStateChange -> Bool
noEnterExitCap StyleStateChange
ApplyStrikethrough = forall a. Maybe a -> Bool
isNothing forall a b. (a -> b) -> a -> b
$ DisplayAttrCaps -> Maybe CapExpression
enterStrikethrough DisplayAttrCaps
caps
        noEnterExitCap StyleStateChange
RemoveStrikethrough = forall a. Maybe a -> Bool
isNothing forall a b. (a -> b) -> a -> b
$ DisplayAttrCaps -> Maybe CapExpression
exitStrikethrough DisplayAttrCaps
caps
        noEnterExitCap StyleStateChange
ApplyItalic = forall a. Maybe a -> Bool
isNothing forall a b. (a -> b) -> a -> b
$ DisplayAttrCaps -> Maybe CapExpression
enterItalic DisplayAttrCaps
caps
        noEnterExitCap StyleStateChange
RemoveItalic = forall a. Maybe a -> Bool
isNothing forall a b. (a -> b) -> a -> b
$ DisplayAttrCaps -> Maybe CapExpression
exitItalic DisplayAttrCaps
caps
        noEnterExitCap StyleStateChange
ApplyStandout = forall a. Maybe a -> Bool
isNothing forall a b. (a -> b) -> a -> b
$ DisplayAttrCaps -> Maybe CapExpression
enterStandout DisplayAttrCaps
caps
        noEnterExitCap StyleStateChange
RemoveStandout = forall a. Maybe a -> Bool
isNothing forall a b. (a -> b) -> a -> b
$ DisplayAttrCaps -> Maybe CapExpression
exitStandout DisplayAttrCaps
caps
        noEnterExitCap StyleStateChange
ApplyUnderline = forall a. Maybe a -> Bool
isNothing forall a b. (a -> b) -> a -> b
$ DisplayAttrCaps -> Maybe CapExpression
enterUnderline DisplayAttrCaps
caps
        noEnterExitCap StyleStateChange
RemoveUnderline = forall a. Maybe a -> Bool
isNothing forall a b. (a -> b) -> a -> b
$ DisplayAttrCaps -> Maybe CapExpression
exitUnderline DisplayAttrCaps
caps
        noEnterExitCap StyleStateChange
ApplyReverseVideo = forall a. Maybe a -> Bool
isNothing 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 = forall a. Maybe a -> Bool
isNothing forall a b. (a -> b) -> a -> b
$ DisplayAttrCaps -> Maybe CapExpression
enterDimMode DisplayAttrCaps
caps
        noEnterExitCap StyleStateChange
RemoveDim = Bool
True
        noEnterExitCap StyleStateChange
ApplyBold = forall a. Maybe a -> Bool
isNothing forall a b. (a -> b) -> a -> b
$ DisplayAttrCaps -> Maybe CapExpression
enterBoldMode DisplayAttrCaps
caps
        noEnterExitCap StyleStateChange
RemoveBold = Bool
True
        enterExitCap :: StyleStateChange -> CapExpression
enterExitCap StyleStateChange
ApplyStrikethrough = forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ DisplayAttrCaps -> Maybe CapExpression
enterStrikethrough DisplayAttrCaps
caps
        enterExitCap StyleStateChange
RemoveStrikethrough = forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ DisplayAttrCaps -> Maybe CapExpression
exitStrikethrough DisplayAttrCaps
caps
        enterExitCap StyleStateChange
ApplyItalic = forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ DisplayAttrCaps -> Maybe CapExpression
enterItalic DisplayAttrCaps
caps
        enterExitCap StyleStateChange
RemoveItalic = forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ DisplayAttrCaps -> Maybe CapExpression
exitItalic DisplayAttrCaps
caps
        enterExitCap StyleStateChange
ApplyStandout = forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ DisplayAttrCaps -> Maybe CapExpression
enterStandout DisplayAttrCaps
caps
        enterExitCap StyleStateChange
RemoveStandout = forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ DisplayAttrCaps -> Maybe CapExpression
exitStandout DisplayAttrCaps
caps
        enterExitCap StyleStateChange
ApplyUnderline = forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ DisplayAttrCaps -> Maybe CapExpression
enterUnderline DisplayAttrCaps
caps
        enterExitCap StyleStateChange
RemoveUnderline = forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ DisplayAttrCaps -> Maybe CapExpression
exitUnderline DisplayAttrCaps
caps
        enterExitCap StyleStateChange
ApplyReverseVideo = forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ DisplayAttrCaps -> Maybe CapExpression
enterReverseVideo DisplayAttrCaps
caps
        enterExitCap StyleStateChange
ApplyDim = forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ DisplayAttrCaps -> Maybe CapExpression
enterDimMode DisplayAttrCaps
caps
        enterExitCap StyleStateChange
ApplyBold = forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ DisplayAttrCaps -> Maybe CapExpression
enterBoldMode DisplayAttrCaps
caps
        enterExitCap StyleStateChange
_ = forall a. HasCallStack => [Char] -> a
error [Char]
"enterExitCap applied to diff that was known not to have one."

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