{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module Graphics.Vty.Platform.Windows.Output.TerminfoBased
( reserveTerminal
, setWindowSize
)
where
import Control.Monad (when)
import Data.Bits ((.&.))
import qualified Data.ByteString as BS
import Data.ByteString.Internal (toForeignPtr)
import Data.Terminfo.Parse
( CapParam, CapExpression, parseCapExpression )
import Data.Terminfo.Eval ( writeCapExpr )
import Graphics.Vty.Attributes
import Graphics.Vty.Image (DisplayRegion)
import Graphics.Vty.DisplayAttributes
import Graphics.Vty.Platform.Windows.WindowsCapabilities (getStringCapability)
import Graphics.Vty.Platform.Windows.WindowsInterfaces ( configureOutput )
import Graphics.Vty.Output
import Blaze.ByteString.Builder (Write, writeToByteString, writeStorable, writeWord8)
import Data.IORef ( newIORef, readIORef, writeIORef )
import Data.Maybe (isJust, isNothing, fromJust)
import Data.Word ( Word8 )
#if !MIN_VERSION_base(4,8,0)
import Data.Foldable (foldMap)
#endif
import Foreign.C.Types (CInt(..))
import Foreign.ForeignPtr (withForeignPtr)
import Foreign.Ptr (Ptr, plusPtr)
import System.IO ( Handle, hPutBufNonBlocking )
import System.Win32.Types ( HANDLE, withHandleToHANDLE )
import System.Win32.Console
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
}
fdWriteAll :: Handle -> Ptr Word8 -> Int -> Int -> IO Int
fdWriteAll :: Handle -> Ptr Word8 -> Int -> Int -> IO Int
fdWriteAll Handle
outHandle Ptr Word8
ptr Int
len Int
count
| Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = [Char] -> IO Int
forall a. [Char] -> IO a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"fdWriteAll: len is less than 0"
| Int
len Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
count
| Bool
otherwise = do
Int
writeCount <- Int -> Int
forall a. Enum a => a -> Int
fromEnum (Int -> Int) -> IO Int -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handle -> Ptr Word8 -> Int -> IO Int
forall a. Handle -> Ptr a -> Int -> IO Int
hPutBufNonBlocking Handle
outHandle Ptr Word8
ptr (Int -> Int
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
Handle -> Ptr Word8 -> Int -> Int -> IO Int
fdWriteAll Handle
outHandle 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
reserveTerminal :: String -> Handle -> ColorMode -> IO Output
reserveTerminal :: [Char] -> Handle -> ColorMode -> IO Output
reserveTerminal [Char]
termName Handle
outHandle ColorMode
colorMode = do
IO ()
restoreMode <- Handle -> IO (IO ())
configureOutput Handle
outHandle
let msetaf :: Maybe CapExpression
msetaf = [Char] -> Maybe CapExpression
probeCap [Char]
"setaf"
msetf :: Maybe CapExpression
msetf = [Char] -> Maybe CapExpression
probeCap [Char]
"setf"
(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, [Char] -> CapExpression
forall a. HasCallStack => [Char] -> a
error ([Char] -> CapExpression) -> [Char] -> CapExpression
forall a b. (a -> b) -> a -> b
$ [Char]
"no fore color support for terminal " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
termName)
msetab :: Maybe CapExpression
msetab = [Char] -> Maybe CapExpression
probeCap [Char]
"setab"
msetb :: Maybe CapExpression
msetb = [Char] -> Maybe CapExpression
probeCap [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 -> [Char] -> CapExpression
forall a. HasCallStack => [Char] -> a
error ([Char] -> CapExpression) -> [Char] -> CapExpression
forall a b. (a -> b) -> a -> b
$ [Char]
"no back color support for terminal " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
termName
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 a. a -> IO a
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 a. a -> IO a
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
terminfoCaps = TerminfoCaps
{ smcup :: Maybe CapExpression
smcup = [Char] -> Maybe CapExpression
probeCap [Char]
"smcup"
, rmcup :: Maybe CapExpression
rmcup = [Char] -> Maybe CapExpression
probeCap [Char]
"rmcup"
, cup :: CapExpression
cup = [Char] -> CapExpression
requireCap [Char]
"cup"
, cnorm :: Maybe CapExpression
cnorm = [Char] -> Maybe CapExpression
probeCap [Char]
"cnorm"
, civis :: Maybe CapExpression
civis = [Char] -> Maybe CapExpression
probeCap [Char]
"civis"
, useAltColorMap :: Bool
useAltColorMap = Bool
useAlt
, setForeColor :: CapExpression
setForeColor = CapExpression
setForeCap
, setBackColor :: CapExpression
setBackColor = CapExpression
setBackCap
, setDefaultAttr :: CapExpression
setDefaultAttr = [Char] -> CapExpression
requireCap [Char]
"sgr0"
, clearScreen :: CapExpression
clearScreen = [Char] -> CapExpression
requireCap [Char]
"clear"
, clearEol :: CapExpression
clearEol = [Char] -> CapExpression
requireCap [Char]
"el"
, displayAttrCaps :: DisplayAttrCaps
displayAttrCaps = DisplayAttrCaps
currentDisplayAttrCaps
, ringBellAudio :: Maybe CapExpression
ringBellAudio = [Char] -> Maybe CapExpression
probeCap [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 []
IO ()
restoreMode
, supportsBell :: IO Bool
supportsBell = Bool -> IO Bool
forall a. a -> IO a
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 a. a -> IO a
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 (DisplayAttrCaps -> Maybe CapExpression
enterItalic (TerminfoCaps -> DisplayAttrCaps
displayAttrCaps TerminfoCaps
terminfoCaps)) Bool -> Bool -> Bool
&&
Maybe CapExpression -> Bool
forall a. Maybe a -> Bool
isJust (DisplayAttrCaps -> Maybe CapExpression
exitItalic (TerminfoCaps -> DisplayAttrCaps
displayAttrCaps TerminfoCaps
terminfoCaps))
, supportsStrikethrough :: IO Bool
supportsStrikethrough = Bool -> IO Bool
forall a. a -> IO a
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 (DisplayAttrCaps -> Maybe CapExpression
enterStrikethrough (TerminfoCaps -> DisplayAttrCaps
displayAttrCaps TerminfoCaps
terminfoCaps)) Bool -> Bool -> Bool
&&
Maybe CapExpression -> Bool
forall a. Maybe a -> Bool
isJust (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
(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) ->
Handle -> (Int, Int) -> IO ()
setWindowSize Handle
outHandle (Int
w, Int
h)
, displayBounds :: IO (Int, Int)
displayBounds = do
(Int, Int)
rawSize <- Handle -> IO (Int, Int)
getWindowSize Handle
outHandle
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 -> [Char] -> IO (Int, Int)
forall a. [Char] -> IO a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> IO (Int, Int)) -> [Char] -> IO (Int, Int)
forall a b. (a -> b) -> a -> b
$ [Char]
"getwinsize returned < 0 : " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Int, Int) -> [Char]
forall a. Show a => a -> [Char]
show (Int, Int)
rawSize
| Bool
otherwise -> (Int, Int) -> IO (Int, Int)
forall a. a -> IO a
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 -> Handle -> Ptr Word8 -> Int -> Int -> IO Int
fdWriteAll Handle
outHandle (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
$ [Char] -> IO ()
forall a. [Char] -> IO a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Graphics.Vty.Output: outputByteBuffer "
[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"length mismatch. " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
len [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" /= " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
actualLen
[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" Please report this bug to vty project."
, 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
, outputColorMode :: ColorMode
outputColorMode = ColorMode
colorMode
, mkDisplayContext :: Output -> (Int, Int) -> IO DisplayContext
mkDisplayContext = (Output -> TerminfoCaps -> (Int, Int) -> IO DisplayContext
`terminfoDisplayContext` TerminfoCaps
terminfoCaps)
, setOutputWindowTitle :: [Char] -> IO ()
setOutputWindowTitle = IO () -> [Char] -> IO ()
forall a b. a -> b -> a
const (IO () -> [Char] -> IO ()) -> IO () -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
}
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Output
t
requireCap :: String -> CapExpression
requireCap :: [Char] -> CapExpression
requireCap [Char]
capName
= case [Char] -> Maybe [Char]
getStringCapability [Char]
capName of
Maybe [Char]
Nothing -> [Char] -> CapExpression
forall a. HasCallStack => [Char] -> a
error ([Char] -> CapExpression) -> [Char] -> CapExpression
forall a b. (a -> b) -> a -> b
$ [Char]
"Terminal does not define required capability \"" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
capName [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\""
Just [Char]
capStr -> [Char] -> CapExpression
parseCap [Char]
capStr
probeCap :: String -> Maybe CapExpression
probeCap :: [Char] -> Maybe CapExpression
probeCap [Char]
capName
= case [Char] -> Maybe [Char]
getStringCapability [Char]
capName of
Maybe [Char]
Nothing -> Maybe CapExpression
forall a. Maybe a
Nothing
Just [Char]
capStr -> CapExpression -> Maybe CapExpression
forall a. a -> Maybe a
Just (CapExpression -> Maybe CapExpression)
-> CapExpression -> Maybe CapExpression
forall a b. (a -> b) -> a -> b
$ [Char] -> CapExpression
parseCap [Char]
capStr
parseCap :: String -> CapExpression
parseCap :: [Char] -> CapExpression
parseCap [Char]
capStr = do
case [Char] -> Either ParseError CapExpression
parseCapExpression [Char]
capStr of
Left ParseError
e -> [Char] -> CapExpression
forall a. HasCallStack => [Char] -> a
error ([Char] -> CapExpression) -> [Char] -> CapExpression
forall a b. (a -> b) -> a -> b
$ ParseError -> [Char]
forall a. Show a => a -> [Char]
show ParseError
e
Right CapExpression
cap -> CapExpression
cap
currentDisplayAttrCaps :: DisplayAttrCaps
currentDisplayAttrCaps :: DisplayAttrCaps
currentDisplayAttrCaps
= DisplayAttrCaps
{ setAttrStates :: Maybe CapExpression
setAttrStates = [Char] -> Maybe CapExpression
probeCap [Char]
"sgr"
, enterStandout :: Maybe CapExpression
enterStandout = [Char] -> Maybe CapExpression
probeCap [Char]
"smso"
, exitStandout :: Maybe CapExpression
exitStandout = [Char] -> Maybe CapExpression
probeCap [Char]
"rmso"
, enterItalic :: Maybe CapExpression
enterItalic = [Char] -> Maybe CapExpression
probeCap [Char]
"sitm"
, exitItalic :: Maybe CapExpression
exitItalic = [Char] -> Maybe CapExpression
probeCap [Char]
"ritm"
, enterStrikethrough :: Maybe CapExpression
enterStrikethrough = [Char] -> Maybe CapExpression
probeCap [Char]
"smxx"
, exitStrikethrough :: Maybe CapExpression
exitStrikethrough = [Char] -> Maybe CapExpression
probeCap [Char]
"rmxx"
, enterUnderline :: Maybe CapExpression
enterUnderline = [Char] -> Maybe CapExpression
probeCap [Char]
"smul"
, exitUnderline :: Maybe CapExpression
exitUnderline = [Char] -> Maybe CapExpression
probeCap [Char]
"rmul"
, enterReverseVideo :: Maybe CapExpression
enterReverseVideo = [Char] -> Maybe CapExpression
probeCap [Char]
"rev"
, enterDimMode :: Maybe CapExpression
enterDimMode = [Char] -> Maybe CapExpression
probeCap [Char]
"dim"
, enterBoldMode :: Maybe CapExpression
enterBoldMode = [Char] -> Maybe CapExpression
probeCap [Char]
"bold"
}
getWindowSize :: Handle -> IO (Int,Int)
getWindowSize :: Handle -> IO (Int, Int)
getWindowSize Handle
handle = do
CONSOLE_SCREEN_BUFFER_INFO
bufferInfo <- Handle
-> (HANDLE -> IO CONSOLE_SCREEN_BUFFER_INFO)
-> IO CONSOLE_SCREEN_BUFFER_INFO
forall a. Handle -> (HANDLE -> IO a) -> IO a
withHandleToHANDLE Handle
handle HANDLE -> IO CONSOLE_SCREEN_BUFFER_INFO
getConsoleScreenBufferInfo
let coord :: COORD
coord = CONSOLE_SCREEN_BUFFER_INFO -> COORD
dwSize CONSOLE_SCREEN_BUFFER_INFO
bufferInfo
(Int, Int) -> IO (Int, Int)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (SHORT -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (SHORT -> Int) -> SHORT -> Int
forall a b. (a -> b) -> a -> b
$ COORD -> SHORT
xPos COORD
coord, SHORT -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (SHORT -> Int) -> SHORT -> Int
forall a b. (a -> b) -> a -> b
$ COORD -> SHORT
yPos COORD
coord)
foreign import ccall "set_screen_size" cSetScreenSize :: CInt -> CInt -> HANDLE -> IO CInt
setWindowSize :: Handle -> (Int, Int) -> IO ()
setWindowSize :: Handle -> (Int, Int) -> IO ()
setWindowSize Handle
hOut (Int
w, Int
h) = do
CInt
result <- Handle -> (HANDLE -> IO CInt) -> IO CInt
forall a. Handle -> (HANDLE -> IO a) -> IO a
withHandleToHANDLE Handle
hOut ((HANDLE -> IO CInt) -> IO CInt) -> (HANDLE -> IO CInt) -> IO CInt
forall a b. (a -> b) -> a -> b
$ CInt -> CInt -> HANDLE -> IO CInt
cSetScreenSize (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
w) (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
h)
if CInt
result CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
0
then () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
else [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Unable to setup window size. Got error code: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ CInt -> [Char]
forall a. Show a => a -> [Char]
show CInt
result
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 a. a -> IO a
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) [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 -> [Char] -> Write
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 -> [Char] -> Write
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) [] 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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
}
writeURLEscapes :: URLDiff -> Write
writeURLEscapes :: URLDiff -> Write
writeURLEscapes (LinkTo ByteString
url) =
(Word8 -> Write) -> [Word8] -> Write
forall m a. Monoid m => (a -> m) -> [a] -> m
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 m a. Monoid m => (a -> m) -> [a] -> m
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 m a. Monoid m => (a -> m) -> [a] -> m
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
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` if (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)
then
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
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 m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (CapExpression -> [CapParam] -> Write
`writeCapExpr` []) [CapExpression]
caps
Write -> Write -> Write
forall a. Monoid a => a -> a -> a
`mappend`
Write
setColors
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
else
case DisplayAttrCaps -> Word8 -> [StyleStateChange] -> DisplayAttrSeq
reqDisplayCapSeqFor (TerminfoCaps -> DisplayAttrCaps
displayAttrCaps TerminfoCaps
terminfoCaps)
(FixedAttr -> Word8
fixedStyle FixedAttr
attr)
(DisplayAttrDiff -> [StyleStateChange]
styleDiffs DisplayAttrDiff
diffs) of
EnterExitSeq [CapExpression]
caps -> (CapExpression -> Write) -> [CapExpression] -> Write
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (CapExpression -> [CapParam] -> Write
`writeCapExpr` []) [CapExpression]
caps
Write -> Write -> Write
forall a. Monoid a => a -> a -> a
`mappend`
ColorSide -> DisplayColorDiff -> Write
writeColorDiff ColorSide
Foreground (DisplayAttrDiff -> DisplayColorDiff
foreColorDiff DisplayAttrDiff
diffs)
Write -> Write -> Write
forall a. Monoid a => a -> a -> a
`mappend`
ColorSide -> DisplayColorDiff -> Write
writeColorDiff ColorSide
Background (DisplayAttrDiff -> DisplayColorDiff
backColorDiff DisplayAttrDiff
diffs)
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
attr :: FixedAttr
attr = FixedAttr -> Attr -> FixedAttr
fixDisplayAttr FixedAttr
prevAttr Attr
reqAttr
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 -> ColorSide -> Color -> Write
writeColor ColorSide
Foreground 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 -> ColorSide -> Color -> Write
writeColor ColorSide
Background Color
c
Maybe Color
Nothing -> Write
forall a. Monoid a => a
mempty)
writeColorDiff :: ColorSide -> DisplayColorDiff -> Write
writeColorDiff ColorSide
_side DisplayColorDiff
NoColorChange
= Write
forall a. Monoid a => a
mempty
writeColorDiff ColorSide
_side DisplayColorDiff
ColorToDefault
= [Char] -> Write
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
_ -> [Char] -> Write
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) [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]
colorMap :: Color -> Int
colorMap = if TerminfoCaps -> Bool
useAltColorMap TerminfoCaps
terminfoCaps
then Color -> Int
altColorIndex
else Color -> Int
ansiColorIndex
data ColorSide = Foreground | Background
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) =
[Write] -> Write
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 (Word8 -> Write) -> (Char -> Word8) -> Char -> Write
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> (Char -> Int) -> Char -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
forall a. Enum a => a -> Int
fromEnum
writeStr :: [Char] -> Write
writeStr = [Write] -> Write
forall a. Monoid a => [a] -> a
mconcat ([Write] -> Write) -> ([Char] -> [Write]) -> [Char] -> Write
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Write) -> [Char] -> [Write]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Write
writeChar
writeColor :: Word8 -> Write
writeColor = [Char] -> Write
writeStr ([Char] -> Write) -> (Word8 -> [Char]) -> Word8 -> Write
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> [Char]
forall a. Show a => a -> [Char]
show
delimiter :: Write
delimiter = Char -> Write
writeChar Char
';'
sideCode :: Write
sideCode = case ColorSide
side of
ColorSide
Foreground -> [Char] -> Write
writeStr [Char]
"38"
ColorSide
Background -> [Char] -> Write
writeStr [Char]
"48"
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
ansiColorIndex (RGBColor Word8
_ Word8
_ Word8
_) =
[Char] -> Int
forall a. HasCallStack => [Char] -> a
error ([Char] -> Int) -> [Char] -> Int
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"
]
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
altColorIndex (RGBColor Word8
_ Word8
_ Word8
_) =
[Char] -> Int
forall a. HasCallStack => [Char] -> a
error ([Char] -> Int) -> [Char] -> Int
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"
]
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
, Bool
False
, Bool
False
]
reqDisplayCapSeqFor :: DisplayAttrCaps -> Style -> [StyleStateChange] -> DisplayAttrSeq
reqDisplayCapSeqFor :: DisplayAttrCaps -> Word8 -> [StyleStateChange] -> DisplayAttrSeq
reqDisplayCapSeqFor DisplayAttrCaps
caps Word8
s [StyleStateChange]
diffs
= 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
( 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
( 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
( 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
_ = [Char] -> CapExpression
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 = [[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]