{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -D_XOPEN_SOURCE=500 -fno-warn-warnings-deprecations #-} {-# CFILES gwinsz.c #-} -- | Terminfo-based terminal output driver. -- -- Copyright Corey O'Connor (coreyoconnor@gmail.com) module Graphics.Vty.Output.TerminfoBased ( reserveTerminal ) where import Control.Monad (when) import qualified Data.ByteString as BS import Data.ByteString.Internal (toForeignPtr) import Data.Terminfo.Parse import Data.Terminfo.Eval import Graphics.Vty.Attributes import Graphics.Vty.Image (DisplayRegion) import Graphics.Vty.DisplayAttributes import Graphics.Vty.Output.Interface import Blaze.ByteString.Builder (Write, writeToByteString, writeStorable) import Control.Monad.Trans import Data.Bits ((.&.)) import Data.Foldable (foldMap) import Data.IORef import Data.Maybe (isJust, isNothing, fromJust) import Data.Word import Foreign.C.Types ( CInt(..), CLong(..) ) import Foreign.ForeignPtr (withForeignPtr) import Foreign.Ptr (Ptr, plusPtr) import qualified System.Console.Terminfo as Terminfo import System.Posix.IO (fdWriteBuf) import System.Posix.Types (Fd(..)) data TerminfoCaps = TerminfoCaps { smcup :: Maybe CapExpression , rmcup :: Maybe CapExpression , cup :: CapExpression , cnorm :: Maybe CapExpression , civis :: Maybe CapExpression , supportsNoColors :: Bool , useAltColorMap :: Bool , setForeColor :: CapExpression , setBackColor :: CapExpression , setDefaultAttr :: CapExpression , clearScreen :: CapExpression , clearEol :: CapExpression , displayAttrCaps :: DisplayAttrCaps , ringBellAudio :: Maybe CapExpression } data DisplayAttrCaps = DisplayAttrCaps { setAttrStates :: Maybe CapExpression , enterStandout :: Maybe CapExpression , exitStandout :: Maybe CapExpression , enterItalic :: Maybe CapExpression , exitItalic :: Maybe CapExpression , enterUnderline :: Maybe CapExpression , exitUnderline :: Maybe CapExpression , enterReverseVideo :: Maybe CapExpression , enterDimMode :: Maybe CapExpression , enterBoldMode :: Maybe CapExpression } -- kinda like: -- https://code.google.com/p/vim/source/browse/src/fileio.c#10422 -- fdWriteBuf will throw on error. Unless the error is EINTR. On EINTR -- the write will be retried. fdWriteAll :: Fd -> Ptr Word8 -> Int -> Int -> IO Int fdWriteAll outFd ptr len count | len < 0 = fail "fdWriteAll: len is less than 0" | len == 0 = return count | otherwise = do writeCount <- fromEnum <$> fdWriteBuf outFd ptr (toEnum len) let len' = len - writeCount ptr' = ptr `plusPtr` writeCount count' = count + writeCount fdWriteAll outFd ptr' len' count' sendCapToTerminal :: Output -> CapExpression -> [CapParam] -> IO () sendCapToTerminal t cap capParams = do outputByteBuffer t $ writeToByteString $ writeCapExpr cap 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 :: ( Applicative m, MonadIO m ) => String -> Fd -> m Output reserveTerminal termName outFd = liftIO $ do ti <- Terminfo.setupTerm termName -- assumes set foreground always implies set background exists. -- if set foreground is not set then all color changing style -- attributes are filtered. msetaf <- probeCap ti "setaf" msetf <- probeCap ti "setf" let (noColors, useAlt, setForeCap) = case msetaf of Just setaf -> (False, False, setaf) Nothing -> case msetf of Just setf -> (False, True, setf) Nothing -> (True, True, error $ "no fore color support for terminal " ++ termName) msetab <- probeCap ti "setab" msetb <- probeCap ti "setb" let set_back_cap = case msetab of Nothing -> case msetb of Just setb -> setb Nothing -> error $ "no back color support for terminal " ++ termName Just setab -> setab hyperlinkModeStatus <- newIORef False newAssumedStateRef <- newIORef initialAssumedState let terminfoSetMode m newStatus = do curStatus <- terminfoModeStatus m when (newStatus /= curStatus) $ case m of Hyperlink -> liftIO $ do writeIORef hyperlinkModeStatus newStatus writeIORef newAssumedStateRef initialAssumedState _ -> return () terminfoModeStatus m = case m of Hyperlink -> liftIO $ readIORef hyperlinkModeStatus _ -> return False terminfoModeSupported Hyperlink = True terminfoModeSupported _ = False terminfoCaps <- pure TerminfoCaps <*> probeCap ti "smcup" <*> probeCap ti "rmcup" <*> requireCap ti "cup" <*> probeCap ti "cnorm" <*> probeCap ti "civis" <*> pure noColors <*> pure useAlt <*> pure setForeCap <*> pure set_back_cap <*> requireCap ti "sgr0" <*> requireCap ti "clear" <*> requireCap ti "el" <*> currentDisplayAttrCaps ti <*> probeCap ti "bel" let t = Output { terminalID = termName , releaseTerminal = liftIO $ do sendCap setDefaultAttr [] maybeSendCap cnorm [] , supportsBell = return $ isJust $ ringBellAudio terminfoCaps , ringTerminalBell = liftIO $ maybeSendCap ringBellAudio [] , reserveDisplay = liftIO $ do -- If there is no support for smcup: Clear the screen -- and then move the mouse to the home position to -- approximate the behavior. maybeSendCap smcup [] sendCap clearScreen [] , releaseDisplay = liftIO $ do maybeSendCap rmcup [] maybeSendCap cnorm [] , displayBounds = do rawSize <- liftIO $ getWindowSize outFd case rawSize of (w, h) | w < 0 || h < 0 -> fail $ "getwinsize returned < 0 : " ++ show rawSize | otherwise -> return (w,h) , outputByteBuffer = \outBytes -> do let (fptr, offset, len) = toForeignPtr outBytes actualLen <- withForeignPtr fptr $ \ptr -> fdWriteAll outFd (ptr `plusPtr` offset) len 0 when (toEnum len /= actualLen) $ fail $ "Graphics.Vty.Output: outputByteBuffer " ++ "length mismatch. " ++ show len ++ " /= " ++ show actualLen ++ " Please report this bug to vty project." , contextColorCount = case supportsNoColors terminfoCaps of False -> case Terminfo.getCapability ti (Terminfo.tiGetNum "colors" ) of Nothing -> 8 Just v -> toEnum v True -> 1 , supportsCursorVisibility = isJust $ civis terminfoCaps , supportsMode = terminfoModeSupported , setMode = terminfoSetMode , getModeStatus = terminfoModeStatus , assumedStateRef = newAssumedStateRef -- I think fix would help assure tActual is the only -- reference. I was having issues tho. , mkDisplayContext = \tActual -> liftIO . terminfoDisplayContext tActual terminfoCaps } sendCap s = sendCapToTerminal t (s terminfoCaps) maybeSendCap s = when (isJust $ s terminfoCaps) . sendCap (fromJust . s) return t requireCap :: (Applicative m, MonadIO m) => Terminfo.Terminal -> String -> m CapExpression requireCap ti capName = case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of Nothing -> fail $ "Terminal does not define required capability \"" ++ capName ++ "\"" Just capStr -> parseCap capStr probeCap :: (Applicative m, MonadIO m) => Terminfo.Terminal -> String -> m (Maybe CapExpression) probeCap ti capName = case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of Nothing -> return Nothing Just capStr -> Just <$> parseCap capStr parseCap :: (Applicative m, MonadIO m) => String -> m CapExpression parseCap capStr = do case parseCapExpression capStr of Left e -> fail $ show e Right cap -> return cap currentDisplayAttrCaps :: ( Applicative m, MonadIO m ) => Terminfo.Terminal -> m DisplayAttrCaps currentDisplayAttrCaps ti = pure DisplayAttrCaps <*> probeCap ti "sgr" <*> probeCap ti "smso" <*> probeCap ti "rmso" <*> probeCap ti "sitm" <*> probeCap ti "ritm" <*> probeCap ti "smul" <*> probeCap ti "rmul" <*> probeCap ti "rev" <*> probeCap ti "dim" <*> probeCap ti "bold" foreign import ccall "gwinsz.h vty_c_get_window_size" c_getWindowSize :: Fd -> IO CLong getWindowSize :: Fd -> IO (Int,Int) getWindowSize fd = do (a,b) <- (`divMod` 65536) `fmap` c_getWindowSize fd return (fromIntegral b, fromIntegral a) terminfoDisplayContext :: Output -> TerminfoCaps -> DisplayRegion -> IO DisplayContext terminfoDisplayContext tActual terminfoCaps r = return dc where dc = DisplayContext { contextDevice = tActual , contextRegion = r , writeMoveCursor = \x y -> writeCapExpr (cup terminfoCaps) [toEnum y, toEnum x] , writeShowCursor = case cnorm terminfoCaps of Nothing -> error "this terminal does not support show cursor" Just c -> writeCapExpr c [] , writeHideCursor = case civis terminfoCaps of Nothing -> error "this terminal does not support hide cursor" Just c -> writeCapExpr c [] , writeSetAttr = terminfoWriteSetAttr dc terminfoCaps , writeDefaultAttr = \urlsEnabled -> writeCapExpr (setDefaultAttr terminfoCaps) [] `mappend` (if urlsEnabled then writeURLEscapes EndLink else mempty) , writeRowEnd = writeCapExpr (clearEol terminfoCaps) [] , inlineHack = 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 (LinkTo url) = foldMap writeStorable (BS.unpack "\x1b]8;;") `mappend` foldMap writeStorable (BS.unpack url) `mappend` writeStorable (0x07 :: Word8) writeURLEscapes EndLink = foldMap writeStorable (BS.unpack "\x1b]8;;\a") writeURLEscapes NoLinkChange = 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 dc terminfoCaps urlsEnabled prevAttr reqAttr diffs = urlAttrs urlsEnabled `mappend` case (foreColorDiff diffs == ColorToDefault) || (backColorDiff diffs == ColorToDefault) of -- The only way to reset either color, portably, to the default -- is to use either the set state capability or the set default -- capability. True -> do case reqDisplayCapSeqFor (displayAttrCaps terminfoCaps) (fixedStyle attr ) (styleToApplySeq $ fixedStyle attr) of -- only way to reset a color to the defaults EnterExitSeq caps -> writeDefaultAttr dc urlsEnabled `mappend` foldMap (\cap -> writeCapExpr cap []) caps `mappend` setColors -- implicitly resets the colors to the defaults SetState state -> writeCapExpr (fromJust $ setAttrStates $ displayAttrCaps $ terminfoCaps ) (sgrArgsForState state) `mappend` setItalics `mappend` setColors -- Otherwise the display colors are not changing or changing -- between two non-default points. False -> do -- Still, it could be the case that the change in display -- attributes requires the colors to be reset because the -- required capability was not available. case reqDisplayCapSeqFor (displayAttrCaps terminfoCaps) (fixedStyle attr) (styleDiffs 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 caps -> foldMap (\cap -> writeCapExpr cap []) caps `mappend` writeColorDiff setForeColor (foreColorDiff diffs) `mappend` writeColorDiff setBackColor (backColorDiff diffs) -- implicitly resets the colors to the defaults SetState state -> writeCapExpr (fromJust $ setAttrStates $ displayAttrCaps terminfoCaps ) (sgrArgsForState state) `mappend` setItalics `mappend` setColors where urlAttrs True = writeURLEscapes (urlDiff diffs) urlAttrs False = mempty colorMap = case useAltColorMap terminfoCaps of False -> ansiColorIndex True -> altColorIndex attr = fixDisplayAttr prevAttr 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 | hasStyle (fixedStyle attr) italic , Just sitm <- enterItalic (displayAttrCaps terminfoCaps) = writeCapExpr sitm [] | otherwise = mempty setColors = (case fixedForeColor attr of Just c -> writeCapExpr (setForeColor terminfoCaps) [toEnum $ colorMap c] Nothing -> mempty) `mappend` (case fixedBackColor attr of Just c -> writeCapExpr (setBackColor terminfoCaps) [toEnum $ colorMap c] Nothing -> mempty) writeColorDiff _f NoColorChange = mempty writeColorDiff _f ColorToDefault = error "ColorToDefault is not a possible case for applyColorDiffs" writeColorDiff f (SetColor c) = writeCapExpr (f terminfoCaps) [toEnum $ colorMap c] -- | The color table used by a terminal is a 16 color set followed by a -- 240 color set that might not be supported by the terminal. -- -- This takes a Color which clearly identifies which pallete to use and -- computes the index into the full 256 color pallete. ansiColorIndex :: Color -> Int ansiColorIndex (ISOColor v) = fromEnum v ansiColorIndex (Color240 v) = 16 + fromEnum v -- | For terminals without setaf/setab -- -- See table in `man terminfo` -- Will error if not in table. altColorIndex :: Color -> Int altColorIndex (ISOColor 0) = 0 altColorIndex (ISOColor 1) = 4 altColorIndex (ISOColor 2) = 2 altColorIndex (ISOColor 3) = 6 altColorIndex (ISOColor 4) = 1 altColorIndex (ISOColor 5) = 5 altColorIndex (ISOColor 6) = 3 altColorIndex (ISOColor 7) = 7 altColorIndex (ISOColor v) = fromEnum v altColorIndex (Color240 v) = 16 + fromEnum v {- | The sequence of terminfo caps to apply a given style are determined - according to these rules. - - 1. The assumption is that it's preferable to use the simpler - enter/exit mode capabilities than the full set display attribute - state capability. - - 2. If a mode is supposed to be removed but there is not an exit - capability defined then the display attributes are reset to defaults - then the display attribute state is set. - - 3. If a mode is supposed to be applied but there is not an enter - capability defined then then display attribute state is set if - possible. Otherwise the mode is not applied. - - 4. If the display attribute state is being set then just update the - arguments to that for any apply/remove. -} data DisplayAttrSeq = EnterExitSeq [CapExpression] | SetState DisplayAttrState data DisplayAttrState = DisplayAttrState { applyStandout :: Bool , applyUnderline :: Bool , applyItalic :: Bool , applyReverseVideo :: Bool , applyBlink :: Bool , applyDim :: Bool , applyBold :: Bool } sgrArgsForState :: DisplayAttrState -> [CapParam] sgrArgsForState attrState = map (\b -> if b then 1 else 0) [ applyStandout attrState , applyUnderline attrState , applyReverseVideo attrState , applyBlink attrState , applyDim attrState , applyBold attrState , False -- invis , False -- protect , False -- alt char set ] reqDisplayCapSeqFor :: DisplayAttrCaps -> Style -> [StyleStateChange] -> DisplayAttrSeq reqDisplayCapSeqFor caps s 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 (any noEnterExitCap diffs, isJust $ setAttrStates caps) of -- If all the diffs have an enter-exit cap then just use those ( False, _ ) -> EnterExitSeq $ map enterExitCap 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 ( True, False ) -> EnterExitSeq $ map enterExitCap $ filter (not . noEnterExitCap) 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. ( True, True ) -> SetState $ stateForStyle s where noEnterExitCap ApplyItalic = isNothing $ enterItalic caps noEnterExitCap RemoveItalic = isNothing $ exitItalic caps noEnterExitCap ApplyStandout = isNothing $ enterStandout caps noEnterExitCap RemoveStandout = isNothing $ exitStandout caps noEnterExitCap ApplyUnderline = isNothing $ enterUnderline caps noEnterExitCap RemoveUnderline = isNothing $ exitUnderline caps noEnterExitCap ApplyReverseVideo = isNothing $ enterReverseVideo caps noEnterExitCap RemoveReverseVideo = True noEnterExitCap ApplyBlink = True noEnterExitCap RemoveBlink = True noEnterExitCap ApplyDim = isNothing $ enterDimMode caps noEnterExitCap RemoveDim = True noEnterExitCap ApplyBold = isNothing $ enterBoldMode caps noEnterExitCap RemoveBold = True enterExitCap ApplyItalic = fromJust $ enterItalic caps enterExitCap RemoveItalic = fromJust $ exitItalic caps enterExitCap ApplyStandout = fromJust $ enterStandout caps enterExitCap RemoveStandout = fromJust $ exitStandout caps enterExitCap ApplyUnderline = fromJust $ enterUnderline caps enterExitCap RemoveUnderline = fromJust $ exitUnderline caps enterExitCap ApplyReverseVideo = fromJust $ enterReverseVideo caps enterExitCap ApplyDim = fromJust $ enterDimMode caps enterExitCap ApplyBold = fromJust $ enterBoldMode caps enterExitCap _ = error "enterExitCap applied to diff that was known not to have one." stateForStyle :: Style -> DisplayAttrState stateForStyle s = DisplayAttrState { applyStandout = isStyleSet standout , applyUnderline = isStyleSet underline , applyItalic = isStyleSet italic , applyReverseVideo = isStyleSet reverseVideo , applyBlink = isStyleSet blink , applyDim = isStyleSet dim , applyBold = isStyleSet bold } where isStyleSet = hasStyle s styleToApplySeq :: Style -> [StyleStateChange] styleToApplySeq s = concat [ applyIfRequired ApplyStandout standout , applyIfRequired ApplyUnderline underline , applyIfRequired ApplyItalic italic , applyIfRequired ApplyReverseVideo reverseVideo , applyIfRequired ApplyBlink blink , applyIfRequired ApplyDim dim , applyIfRequired ApplyBold bold ] where applyIfRequired op flag = if 0 == (flag .&. s) then [] else [op]