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