{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}

-- | Provides functions for configuring the terminal for VT processing, and to 

-- change the window size

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
    }

-- 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 :: 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

-- | 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 -> 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

    -- assumes set foreground always implies set background exists.

    -- if set foreground is not set then all color changing style

    -- attributes are filtered.

    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
                -- 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) ->
                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
            -- 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)
            , 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

-- | Resize the console window to the specified size. Throws error on failure.

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 ()
            }

-- | Write the escape sequences that are used in some terminals to

-- include embedded hyperlinks. As of yet, this information isn't

-- included in termcap or terminfo, so this writes them directly

-- instead of looking up the appropriate capabilities.

writeURLEscapes :: URLDiff -> Write
writeURLEscapes :: URLDiff -> Write
writeURLEscapes (LinkTo ByteString
url) =
    (Word8 -> Write) -> [Word8] -> Write
forall 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

-- | Portably setting the display attributes is a giant pain in the ass.

--

-- If the terminal supports the sgr capability (which sets the on/off

-- state of each style directly; and, for no good reason, resets the

-- colors to the default) this procedure is used:

--

--  0. set the style attributes. This resets the fore and back color.

--

--  1, If a foreground color is to be set then set the foreground color

--

--  2. likewise with the background color

--

-- If the terminal does not support the sgr cap then: if there is a

-- change from an applied color to the default (in either the fore or

-- back color) then:

--

--  0. reset all display attributes (sgr0)

--

--  1. enter required style modes

--

--  2. set the fore color if required

--

--  3. set the back color if required

--

-- Entering the required style modes could require a reset of the

-- display attributes. If this is the case then the back and fore colors

-- always need to be set if not default.

--

-- This equation implements the above logic.

--

-- Note that this assumes the removal of color changes in the

-- display attributes is done as expected with noColors == True. See

-- `limitAttrForDisplay`.

--

-- Note that this optimizes for fewer state changes followed by fewer

-- bytes.

terminfoWriteSetAttr :: DisplayContext -> TerminfoCaps -> Bool -> FixedAttr -> Attr -> DisplayAttrDiff -> Write
terminfoWriteSetAttr :: DisplayContext
-> TerminfoCaps
-> Bool
-> FixedAttr
-> Attr
-> DisplayAttrDiff
-> Write
terminfoWriteSetAttr DisplayContext
dc TerminfoCaps
terminfoCaps Bool
urlsEnabled FixedAttr
prevAttr Attr
reqAttr DisplayAttrDiff
diffs =
    Bool -> Write
urlAttrs Bool
urlsEnabled Write -> Write -> Write
forall a. Monoid a => a -> a -> a
`mappend` 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)
        -- The only way to reset either color, portably, to the default

        -- is to use either the set state capability or the set default

        -- capability.

        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
                -- only way to reset a color to the defaults

                EnterExitSeq [CapExpression]
caps -> DisplayContext -> Bool -> Write
writeDefaultAttr DisplayContext
dc Bool
urlsEnabled
                                     Write -> Write -> Write
forall a. Monoid a => a -> a -> a
`mappend`
                                     (CapExpression -> Write) -> [CapExpression] -> Write
forall 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
                -- implicitly resets the colors to the defaults

                SetState DisplayAttrState
state -> CapExpression -> [CapParam] -> Write
writeCapExpr (Maybe CapExpression -> CapExpression
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe CapExpression -> CapExpression)
-> Maybe CapExpression -> CapExpression
forall a b. (a -> b) -> a -> b
$ DisplayAttrCaps -> Maybe CapExpression
setAttrStates
                                                         (DisplayAttrCaps -> Maybe CapExpression)
-> DisplayAttrCaps -> Maybe CapExpression
forall a b. (a -> b) -> a -> b
$ TerminfoCaps -> DisplayAttrCaps
displayAttrCaps TerminfoCaps
terminfoCaps
                                               )
                                               (DisplayAttrState -> [CapParam]
sgrArgsForState DisplayAttrState
state)
                                  Write -> Write -> Write
forall a. Monoid a => a -> a -> a
`mappend` Write
setItalics
                                  Write -> Write -> Write
forall a. Monoid a => a -> a -> a
`mappend` Write
setStrikethrough
                                  Write -> Write -> Write
forall a. Monoid a => a -> a -> a
`mappend` Write
setColors
        -- Otherwise the display colors are not changing or changing

        -- between two non-default points.

        else
            -- Still, it could be the case that the change in display

            -- attributes requires the colors to be reset because the

            -- required capability was not available.

            case DisplayAttrCaps -> Word8 -> [StyleStateChange] -> DisplayAttrSeq
reqDisplayCapSeqFor (TerminfoCaps -> DisplayAttrCaps
displayAttrCaps TerminfoCaps
terminfoCaps)
                                     (FixedAttr -> Word8
fixedStyle FixedAttr
attr)
                                     (DisplayAttrDiff -> [StyleStateChange]
styleDiffs DisplayAttrDiff
diffs) of
                -- Really, if terminals were re-implemented with modern

                -- concepts instead of bowing down to 40 yr old dumb

                -- terminal requirements this would be the only case

                -- ever reached! Changes the style and color states

                -- according to the differences with the currently

                -- applied states.

                EnterExitSeq [CapExpression]
caps -> (CapExpression -> Write) -> [CapExpression] -> Write
forall 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)
                -- implicitly resets the colors to the defaults

                SetState DisplayAttrState
state -> CapExpression -> [CapParam] -> Write
writeCapExpr (Maybe CapExpression -> CapExpression
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe CapExpression -> CapExpression)
-> Maybe CapExpression -> CapExpression
forall a b. (a -> b) -> a -> b
$ DisplayAttrCaps -> Maybe CapExpression
setAttrStates
                                                         (DisplayAttrCaps -> Maybe CapExpression)
-> DisplayAttrCaps -> Maybe CapExpression
forall a b. (a -> b) -> a -> b
$ TerminfoCaps -> DisplayAttrCaps
displayAttrCaps TerminfoCaps
terminfoCaps
                                               )
                                               (DisplayAttrState -> [CapParam]
sgrArgsForState DisplayAttrState
state)
                                  Write -> Write -> Write
forall a. Monoid a => a -> a -> a
`mappend` Write
setItalics
                                  Write -> Write -> Write
forall a. Monoid a => a -> a -> a
`mappend` Write
setStrikethrough
                                  Write -> Write -> Write
forall a. Monoid a => a -> a -> a
`mappend` Write
setColors
    where
        urlAttrs :: Bool -> Write
urlAttrs Bool
True = URLDiff -> Write
writeURLEscapes (DisplayAttrDiff -> URLDiff
urlDiff DisplayAttrDiff
diffs)
        urlAttrs Bool
False = Write
forall a. Monoid a => a
mempty
        attr :: FixedAttr
attr = FixedAttr -> Attr -> FixedAttr
fixDisplayAttr FixedAttr
prevAttr Attr
reqAttr

        -- italics can't be set via SGR, so here we manually

        -- apply the enter and exit sequences as needed after

        -- changing the SGR

        setItalics :: Write
setItalics
          | Word8 -> Word8 -> Bool
hasStyle (FixedAttr -> Word8
fixedStyle FixedAttr
attr) Word8
italic
          , Just CapExpression
sitm <- DisplayAttrCaps -> Maybe CapExpression
enterItalic (TerminfoCaps -> DisplayAttrCaps
displayAttrCaps TerminfoCaps
terminfoCaps)
          = CapExpression -> [CapParam] -> Write
writeCapExpr CapExpression
sitm []
          | Bool
otherwise = Write
forall a. Monoid a => a
mempty
        setStrikethrough :: Write
setStrikethrough
          | Word8 -> Word8 -> Bool
hasStyle (FixedAttr -> Word8
fixedStyle FixedAttr
attr) Word8
strikethrough
          , Just CapExpression
smxx <- DisplayAttrCaps -> Maybe CapExpression
enterStrikethrough (TerminfoCaps -> DisplayAttrCaps
displayAttrCaps TerminfoCaps
terminfoCaps)
          = CapExpression -> [CapParam] -> Write
writeCapExpr CapExpression
smxx []
          | Bool
otherwise = Write
forall a. Monoid a => a
mempty
        setColors :: Write
setColors =
            (case FixedAttr -> Maybe Color
fixedForeColor FixedAttr
attr of
                Just Color
c -> 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

-- 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"

    [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
';'
        -- 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) = 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"
                    ]

-- | For terminals without setaf/setab

--

-- See table in `man terminfo`

-- Will error if not in table.

altColorIndex :: Color -> Int
altColorIndex :: Color -> Int
altColorIndex (ISOColor Word8
0) = Int
0
altColorIndex (ISOColor Word8
1) = Int
4
altColorIndex (ISOColor Word8
2) = Int
2
altColorIndex (ISOColor Word8
3) = Int
6
altColorIndex (ISOColor Word8
4) = Int
1
altColorIndex (ISOColor Word8
5) = Int
5
altColorIndex (ISOColor Word8
6) = Int
3
altColorIndex (ISOColor Word8
7) = Int
7
altColorIndex (ISOColor Word8
v) = Word8 -> Int
forall a. Enum a => a -> Int
fromEnum Word8
v
altColorIndex (Color240 Word8
v) = Int
16 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Word8 -> Int
forall a. Enum a => a -> Int
fromEnum Word8
v
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"
                    ]

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

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

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

    , Bool
False -- protect

    , Bool
False -- alt char set

    ]

reqDisplayCapSeqFor :: DisplayAttrCaps -> Style -> [StyleStateChange] -> DisplayAttrSeq
reqDisplayCapSeqFor :: DisplayAttrCaps -> Word8 -> [StyleStateChange] -> DisplayAttrSeq
reqDisplayCapSeqFor DisplayAttrCaps
caps Word8
s [StyleStateChange]
diffs
    -- if the state transition implied by any diff cannot be supported

    -- with an enter/exit mode cap then either the state needs to be set

    -- or the attribute change ignored.

    = case ((StyleStateChange -> Bool) -> [StyleStateChange] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any StyleStateChange -> Bool
noEnterExitCap [StyleStateChange]
diffs, Maybe CapExpression -> Bool
forall a. Maybe a -> Bool
isJust (Maybe CapExpression -> Bool) -> Maybe CapExpression -> Bool
forall a b. (a -> b) -> a -> b
$ DisplayAttrCaps -> Maybe CapExpression
setAttrStates DisplayAttrCaps
caps) of
        -- If all the diffs have an enter-exit cap then just use those

        ( Bool
False, Bool
_    ) -> [CapExpression] -> DisplayAttrSeq
EnterExitSeq ([CapExpression] -> DisplayAttrSeq)
-> [CapExpression] -> DisplayAttrSeq
forall a b. (a -> b) -> a -> b
$ (StyleStateChange -> CapExpression)
-> [StyleStateChange] -> [CapExpression]
forall a b. (a -> b) -> [a] -> [b]
map StyleStateChange -> CapExpression
enterExitCap [StyleStateChange]
diffs
        -- If not all the diffs have an enter-exit cap and there is no

        -- set state cap then filter out all unsupported diffs and just

        -- apply the rest

        ( Bool
True, Bool
False ) -> [CapExpression] -> DisplayAttrSeq
EnterExitSeq ([CapExpression] -> DisplayAttrSeq)
-> [CapExpression] -> DisplayAttrSeq
forall a b. (a -> b) -> a -> b
$ (StyleStateChange -> CapExpression)
-> [StyleStateChange] -> [CapExpression]
forall a b. (a -> b) -> [a] -> [b]
map StyleStateChange -> CapExpression
enterExitCap
                                        ([StyleStateChange] -> [CapExpression])
-> [StyleStateChange] -> [CapExpression]
forall a b. (a -> b) -> a -> b
$ (StyleStateChange -> Bool)
-> [StyleStateChange] -> [StyleStateChange]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> (StyleStateChange -> Bool) -> StyleStateChange -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StyleStateChange -> Bool
noEnterExitCap) [StyleStateChange]
diffs
        -- if not all the diffs have an enter-exit can and there is a

        -- set state cap then just use the set state cap.

        ( Bool
True, Bool
True  ) -> DisplayAttrState -> DisplayAttrSeq
SetState (DisplayAttrState -> DisplayAttrSeq)
-> DisplayAttrState -> DisplayAttrSeq
forall a b. (a -> b) -> a -> b
$ Word8 -> DisplayAttrState
stateForStyle Word8
s
    where
        noEnterExitCap :: StyleStateChange -> Bool
noEnterExitCap StyleStateChange
ApplyStrikethrough = Maybe CapExpression -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe CapExpression -> Bool) -> Maybe CapExpression -> Bool
forall a b. (a -> b) -> a -> b
$ DisplayAttrCaps -> Maybe CapExpression
enterStrikethrough DisplayAttrCaps
caps
        noEnterExitCap StyleStateChange
RemoveStrikethrough = Maybe CapExpression -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe CapExpression -> Bool) -> Maybe CapExpression -> Bool
forall a b. (a -> b) -> a -> b
$ DisplayAttrCaps -> Maybe CapExpression
exitStrikethrough DisplayAttrCaps
caps
        noEnterExitCap StyleStateChange
ApplyItalic = Maybe CapExpression -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe CapExpression -> Bool) -> Maybe CapExpression -> Bool
forall a b. (a -> b) -> a -> b
$ DisplayAttrCaps -> Maybe CapExpression
enterItalic DisplayAttrCaps
caps
        noEnterExitCap StyleStateChange
RemoveItalic = Maybe CapExpression -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe CapExpression -> Bool) -> Maybe CapExpression -> Bool
forall a b. (a -> b) -> a -> b
$ DisplayAttrCaps -> Maybe CapExpression
exitItalic DisplayAttrCaps
caps
        noEnterExitCap StyleStateChange
ApplyStandout = Maybe CapExpression -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe CapExpression -> Bool) -> Maybe CapExpression -> Bool
forall a b. (a -> b) -> a -> b
$ DisplayAttrCaps -> Maybe CapExpression
enterStandout DisplayAttrCaps
caps
        noEnterExitCap StyleStateChange
RemoveStandout = Maybe CapExpression -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe CapExpression -> Bool) -> Maybe CapExpression -> Bool
forall a b. (a -> b) -> a -> b
$ DisplayAttrCaps -> Maybe CapExpression
exitStandout DisplayAttrCaps
caps
        noEnterExitCap StyleStateChange
ApplyUnderline = Maybe CapExpression -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe CapExpression -> Bool) -> Maybe CapExpression -> Bool
forall a b. (a -> b) -> a -> b
$ DisplayAttrCaps -> Maybe CapExpression
enterUnderline DisplayAttrCaps
caps
        noEnterExitCap StyleStateChange
RemoveUnderline = Maybe CapExpression -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe CapExpression -> Bool) -> Maybe CapExpression -> Bool
forall a b. (a -> b) -> a -> b
$ DisplayAttrCaps -> Maybe CapExpression
exitUnderline DisplayAttrCaps
caps
        noEnterExitCap StyleStateChange
ApplyReverseVideo = Maybe CapExpression -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe CapExpression -> Bool) -> Maybe CapExpression -> Bool
forall a b. (a -> b) -> a -> b
$ DisplayAttrCaps -> Maybe CapExpression
enterReverseVideo DisplayAttrCaps
caps
        noEnterExitCap StyleStateChange
RemoveReverseVideo = Bool
True
        noEnterExitCap StyleStateChange
ApplyBlink = Bool
True
        noEnterExitCap StyleStateChange
RemoveBlink = Bool
True
        noEnterExitCap StyleStateChange
ApplyDim = Maybe CapExpression -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe CapExpression -> Bool) -> Maybe CapExpression -> Bool
forall a b. (a -> b) -> a -> b
$ DisplayAttrCaps -> Maybe CapExpression
enterDimMode DisplayAttrCaps
caps
        noEnterExitCap StyleStateChange
RemoveDim = Bool
True
        noEnterExitCap StyleStateChange
ApplyBold = Maybe CapExpression -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe CapExpression -> Bool) -> Maybe CapExpression -> Bool
forall a b. (a -> b) -> a -> b
$ DisplayAttrCaps -> Maybe CapExpression
enterBoldMode DisplayAttrCaps
caps
        noEnterExitCap StyleStateChange
RemoveBold = Bool
True
        enterExitCap :: StyleStateChange -> CapExpression
enterExitCap StyleStateChange
ApplyStrikethrough = Maybe CapExpression -> CapExpression
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe CapExpression -> CapExpression)
-> Maybe CapExpression -> CapExpression
forall a b. (a -> b) -> a -> b
$ DisplayAttrCaps -> Maybe CapExpression
enterStrikethrough DisplayAttrCaps
caps
        enterExitCap StyleStateChange
RemoveStrikethrough = Maybe CapExpression -> CapExpression
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe CapExpression -> CapExpression)
-> Maybe CapExpression -> CapExpression
forall a b. (a -> b) -> a -> b
$ DisplayAttrCaps -> Maybe CapExpression
exitStrikethrough DisplayAttrCaps
caps
        enterExitCap StyleStateChange
ApplyItalic = Maybe CapExpression -> CapExpression
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe CapExpression -> CapExpression)
-> Maybe CapExpression -> CapExpression
forall a b. (a -> b) -> a -> b
$ DisplayAttrCaps -> Maybe CapExpression
enterItalic DisplayAttrCaps
caps
        enterExitCap StyleStateChange
RemoveItalic = Maybe CapExpression -> CapExpression
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe CapExpression -> CapExpression)
-> Maybe CapExpression -> CapExpression
forall a b. (a -> b) -> a -> b
$ DisplayAttrCaps -> Maybe CapExpression
exitItalic DisplayAttrCaps
caps
        enterExitCap StyleStateChange
ApplyStandout = Maybe CapExpression -> CapExpression
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe CapExpression -> CapExpression)
-> Maybe CapExpression -> CapExpression
forall a b. (a -> b) -> a -> b
$ DisplayAttrCaps -> Maybe CapExpression
enterStandout DisplayAttrCaps
caps
        enterExitCap StyleStateChange
RemoveStandout = Maybe CapExpression -> CapExpression
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe CapExpression -> CapExpression)
-> Maybe CapExpression -> CapExpression
forall a b. (a -> b) -> a -> b
$ DisplayAttrCaps -> Maybe CapExpression
exitStandout DisplayAttrCaps
caps
        enterExitCap StyleStateChange
ApplyUnderline = Maybe CapExpression -> CapExpression
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe CapExpression -> CapExpression)
-> Maybe CapExpression -> CapExpression
forall a b. (a -> b) -> a -> b
$ DisplayAttrCaps -> Maybe CapExpression
enterUnderline DisplayAttrCaps
caps
        enterExitCap StyleStateChange
RemoveUnderline = Maybe CapExpression -> CapExpression
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe CapExpression -> CapExpression)
-> Maybe CapExpression -> CapExpression
forall a b. (a -> b) -> a -> b
$ DisplayAttrCaps -> Maybe CapExpression
exitUnderline DisplayAttrCaps
caps
        enterExitCap StyleStateChange
ApplyReverseVideo = Maybe CapExpression -> CapExpression
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe CapExpression -> CapExpression)
-> Maybe CapExpression -> CapExpression
forall a b. (a -> b) -> a -> b
$ DisplayAttrCaps -> Maybe CapExpression
enterReverseVideo DisplayAttrCaps
caps
        enterExitCap StyleStateChange
ApplyDim = Maybe CapExpression -> CapExpression
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe CapExpression -> CapExpression)
-> Maybe CapExpression -> CapExpression
forall a b. (a -> b) -> a -> b
$ DisplayAttrCaps -> Maybe CapExpression
enterDimMode DisplayAttrCaps
caps
        enterExitCap StyleStateChange
ApplyBold = Maybe CapExpression -> CapExpression
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe CapExpression -> CapExpression)
-> Maybe CapExpression -> CapExpression
forall a b. (a -> b) -> a -> b
$ DisplayAttrCaps -> Maybe CapExpression
enterBoldMode DisplayAttrCaps
caps
        enterExitCap StyleStateChange
_ = [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]