1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
|
#if __GLASGOW_HASKELL__ >= 703
{-# LANGUAGE Safe #-}
#endif
-- |
-- Maintainer : judah.jacobson@gmail.com
-- Stability : experimental
-- Portability : portable (FFI)
module System.Console.Terminfo.Effects(
-- * Bell alerts
bell,visualBell,
-- * Text attributes
Attributes(..),
defaultAttributes,
withAttributes,
setAttributes,
allAttributesOff,
-- ** Mode wrappers
withStandout,
withUnderline,
withBold,
-- ** Low-level capabilities
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)
-- | Turns on standout mode before outputting the given
-- text, and then turns it off.
withStandout :: TermStr s => Capability (s -> s)
withStandout = wrapWith enterStandoutMode exitStandoutMode
-- | Turns on underline mode before outputting the given
-- text, and then turns it off.
withUnderline :: TermStr s => Capability (s -> s)
withUnderline = wrapWith enterUnderlineMode exitUnderlineMode
-- | Turns on bold mode before outputting the given text, and then turns
-- all attributes off.
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"
-- | Turns off all text attributes. This capability will always succeed, but it has
-- no effect in terminals which do not support text attributes.
allAttributesOff :: TermStr s => Capability s
allAttributesOff = tiGetOutput1 "sgr0" `mplus` return mempty
data Attributes = Attributes {
standoutAttr,
underlineAttr,
reverseAttr,
blinkAttr,
dimAttr,
boldAttr,
invisibleAttr,
protectedAttr :: Bool
-- NB: I'm not including the "alternate character set."
}
-- | Sets the attributes on or off before outputting the given text,
-- and then turns them all off. This capability will always succeed; properties
-- which cannot be set in the current terminal will be ignored.
withAttributes :: TermStr s => Capability (Attributes -> s -> s)
withAttributes = do
set <- setAttributes
off <- allAttributesOff
return $ \attrs to -> set attrs <#> to <#> off
-- | Sets the attributes on or off. This capability will always succeed;
-- properties which cannot be set in the current terminal will be ignored.
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) -- for alt. character sets
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
-- | These attributes have all properties turned off.
defaultAttributes :: Attributes
defaultAttributes = Attributes False False False False False False False False
-- | Sound the audible bell.
bell :: TermStr s => Capability s
bell = tiGetOutput1 "bel"
-- | Present a visual alert using the @flash@ capability.
visualBell :: Capability TermOutput
visualBell = tiGetOutput1 "flash"
|
