#if __GLASGOW_HASKELL__ >= 703
#endif
module System.Console.Terminfo.Effects(
bell,visualBell,
Attributes(..),
defaultAttributes,
withAttributes,
setAttributes,
allAttributesOff,
withStandout,
withUnderline,
withBold,
enterStandoutMode,
exitStandoutMode,
enterUnderlineMode,
exitUnderlineMode,
reverseOn,
blinkOn,
boldOn,
dimOn,
invisibleOn,
protectedOn
) where
import System.Console.Terminfo.Base
import Control.Monad
wrapWith :: TermStr s => Capability s -> Capability s -> Capability (s -> s)
wrapWith start end = do
s <- start
e <- end
return (\t -> s <#> t <#> e)
withStandout :: TermStr s => Capability (s -> s)
withStandout = wrapWith enterStandoutMode exitStandoutMode
withUnderline :: TermStr s => Capability (s -> s)
withUnderline = wrapWith enterUnderlineMode exitUnderlineMode
withBold :: TermStr s => Capability (s -> s)
withBold = wrapWith boldOn allAttributesOff
enterStandoutMode :: TermStr s => Capability s
enterStandoutMode = tiGetOutput1 "smso"
exitStandoutMode :: TermStr s => Capability s
exitStandoutMode = tiGetOutput1 "rmso"
enterUnderlineMode :: TermStr s => Capability s
enterUnderlineMode = tiGetOutput1 "smul"
exitUnderlineMode :: TermStr s => Capability s
exitUnderlineMode = tiGetOutput1 "rmul"
reverseOn :: TermStr s => Capability s
reverseOn = tiGetOutput1 "rev"
blinkOn:: TermStr s => Capability s
blinkOn = tiGetOutput1 "blink"
boldOn :: TermStr s => Capability s
boldOn = tiGetOutput1 "bold"
dimOn :: TermStr s => Capability s
dimOn = tiGetOutput1 "dim"
invisibleOn :: TermStr s => Capability s
invisibleOn = tiGetOutput1 "invis"
protectedOn :: TermStr s => Capability s
protectedOn = tiGetOutput1 "prot"
allAttributesOff :: TermStr s => Capability s
allAttributesOff = tiGetOutput1 "sgr0" `mplus` return mempty
data Attributes = Attributes {
standoutAttr,
underlineAttr,
reverseAttr,
blinkAttr,
dimAttr,
boldAttr,
invisibleAttr,
protectedAttr :: Bool
}
withAttributes :: TermStr s => Capability (Attributes -> s -> s)
withAttributes = do
set <- setAttributes
off <- allAttributesOff
return $ \attrs to -> set attrs <#> to <#> off
setAttributes :: TermStr s => Capability (Attributes -> s)
setAttributes = usingSGR0 `mplus` manualSets
where
usingSGR0 = do
sgr <- tiGetOutput1 "sgr"
return $ \a -> let mkAttr f = if f a then 1 else 0 :: Int
in sgr (mkAttr standoutAttr)
(mkAttr underlineAttr)
(mkAttr reverseAttr)
(mkAttr blinkAttr)
(mkAttr dimAttr)
(mkAttr boldAttr)
(mkAttr invisibleAttr)
(mkAttr protectedAttr)
(0::Int)
attrCap :: TermStr s => (Attributes -> Bool) -> Capability s
-> Capability (Attributes -> s)
attrCap f cap = do {to <- cap; return $ \a -> if f a then to else mempty}
`mplus` return (const mempty)
manualSets = do
cs <- sequence [attrCap standoutAttr enterStandoutMode
, attrCap underlineAttr enterUnderlineMode
, attrCap reverseAttr reverseOn
, attrCap blinkAttr blinkOn
, attrCap boldAttr boldOn
, attrCap dimAttr dimOn
, attrCap invisibleAttr invisibleOn
, attrCap protectedAttr protectedOn
]
return $ \a -> mconcat $ map ($ a) cs
defaultAttributes :: Attributes
defaultAttributes = Attributes False False False False False False False False
bell :: TermStr s => Capability s
bell = tiGetOutput1 "bel"
visualBell :: Capability TermOutput
visualBell = tiGetOutput1 "flash"