{-# LANGUAGE CPP #-}
#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 :: 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
    forall (m :: * -> *) a. Monad m => a -> m a
return (\s
t -> s
s forall m. Monoid m => m -> m -> m
<#> s
t forall m. Monoid m => m -> m -> m
<#> s
e)

-- | Turns on standout mode before outputting the given
-- text, and then turns it off.
withStandout :: TermStr s => Capability (s -> s)
withStandout :: forall s. TermStr s => Capability (s -> s)
withStandout = forall s.
TermStr s =>
Capability s -> Capability s -> Capability (s -> s)
wrapWith forall s. TermStr s => Capability s
enterStandoutMode forall s. TermStr s => Capability s
exitStandoutMode

-- | Turns on underline mode before outputting the given
-- text, and then turns it off.
withUnderline :: TermStr s => Capability (s -> s)
withUnderline :: forall s. TermStr s => Capability (s -> s)
withUnderline = forall s.
TermStr s =>
Capability s -> Capability s -> Capability (s -> s)
wrapWith forall s. TermStr s => Capability s
enterUnderlineMode forall s. TermStr s => Capability s
exitUnderlineMode

-- | Turns on bold mode before outputting the given text, and then turns
-- all attributes off.
withBold :: TermStr s => Capability (s -> s)
withBold :: forall s. TermStr s => Capability (s -> s)
withBold = forall s.
TermStr s =>
Capability s -> Capability s -> Capability (s -> s)
wrapWith forall s. TermStr s => Capability s
boldOn forall s. TermStr s => Capability s
allAttributesOff

enterStandoutMode :: TermStr s => Capability s
enterStandoutMode :: forall s. TermStr s => Capability s
enterStandoutMode = forall f. OutputCap f => String -> Capability f
tiGetOutput1 String
"smso"

exitStandoutMode :: TermStr s => Capability s
exitStandoutMode :: forall s. TermStr s => Capability s
exitStandoutMode = forall f. OutputCap f => String -> Capability f
tiGetOutput1 String
"rmso"

enterUnderlineMode :: TermStr s => Capability s
enterUnderlineMode :: forall s. TermStr s => Capability s
enterUnderlineMode = forall f. OutputCap f => String -> Capability f
tiGetOutput1 String
"smul"

exitUnderlineMode :: TermStr s => Capability s
exitUnderlineMode :: forall s. TermStr s => Capability s
exitUnderlineMode = forall f. OutputCap f => String -> Capability f
tiGetOutput1 String
"rmul"

reverseOn :: TermStr s => Capability s
reverseOn :: forall s. TermStr s => Capability s
reverseOn = forall f. OutputCap f => String -> Capability f
tiGetOutput1 String
"rev"

blinkOn:: TermStr s => Capability s
blinkOn :: forall s. TermStr s => Capability s
blinkOn = forall f. OutputCap f => String -> Capability f
tiGetOutput1 String
"blink"

boldOn :: TermStr s => Capability s
boldOn :: forall s. TermStr s => Capability s
boldOn = forall f. OutputCap f => String -> Capability f
tiGetOutput1 String
"bold"

dimOn :: TermStr s => Capability s
dimOn :: forall s. TermStr s => Capability s
dimOn = forall f. OutputCap f => String -> Capability f
tiGetOutput1 String
"dim"

invisibleOn :: TermStr s => Capability s
invisibleOn :: forall s. TermStr s => Capability s
invisibleOn = forall f. OutputCap f => String -> Capability f
tiGetOutput1 String
"invis"

protectedOn :: TermStr s => Capability s
protectedOn :: forall s. TermStr s => Capability s
protectedOn = forall f. OutputCap f => String -> Capability f
tiGetOutput1 String
"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 :: forall s. TermStr s => Capability s
allAttributesOff = forall f. OutputCap f => String -> Capability f
tiGetOutput1 String
"sgr0" forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` forall (m :: * -> *) a. Monad m => a -> m a
return 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
                -- 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 :: forall s. TermStr s => Capability (Attributes -> s -> s)
withAttributes = do
    Attributes -> s
set <- forall s. TermStr s => Capability (Attributes -> s)
setAttributes
    s
off <- forall s. TermStr s => Capability s
allAttributesOff
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ \Attributes
attrs s
to -> Attributes -> s
set Attributes
attrs forall m. Monoid m => m -> m -> m
<#> s
to forall m. Monoid m => m -> m -> m
<#> s
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 :: forall s. TermStr s => Capability (Attributes -> s)
setAttributes = Capability (Attributes -> s)
usingSGR0 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 <- forall f. OutputCap f => String -> Capability f
tiGetOutput1 String
"sgr"
            forall (m :: * -> *) a. Monad m => a -> m a
return 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) -- for alt. character sets
        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; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ \Attributes
a -> if Attributes -> Bool
f Attributes
a then s
to else forall a. Monoid a => a
mempty}
                        forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> b -> a
const forall a. Monoid a => a
mempty)
        manualSets :: Capability (Attributes -> s)
manualSets = do
            [Attributes -> s]
cs <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [forall s.
TermStr s =>
(Attributes -> Bool)
-> Capability s -> Capability (Attributes -> s)
attrCap Attributes -> Bool
standoutAttr forall s. TermStr s => Capability s
enterStandoutMode
                            , forall s.
TermStr s =>
(Attributes -> Bool)
-> Capability s -> Capability (Attributes -> s)
attrCap Attributes -> Bool
underlineAttr forall s. TermStr s => Capability s
enterUnderlineMode
                            , forall s.
TermStr s =>
(Attributes -> Bool)
-> Capability s -> Capability (Attributes -> s)
attrCap Attributes -> Bool
reverseAttr forall s. TermStr s => Capability s
reverseOn
                            , forall s.
TermStr s =>
(Attributes -> Bool)
-> Capability s -> Capability (Attributes -> s)
attrCap Attributes -> Bool
blinkAttr forall s. TermStr s => Capability s
blinkOn
                            , forall s.
TermStr s =>
(Attributes -> Bool)
-> Capability s -> Capability (Attributes -> s)
attrCap Attributes -> Bool
boldAttr forall s. TermStr s => Capability s
boldOn
                            , forall s.
TermStr s =>
(Attributes -> Bool)
-> Capability s -> Capability (Attributes -> s)
attrCap Attributes -> Bool
dimAttr forall s. TermStr s => Capability s
dimOn
                            , forall s.
TermStr s =>
(Attributes -> Bool)
-> Capability s -> Capability (Attributes -> s)
attrCap Attributes -> Bool
invisibleAttr forall s. TermStr s => Capability s
invisibleOn
                            , forall s.
TermStr s =>
(Attributes -> Bool)
-> Capability s -> Capability (Attributes -> s)
attrCap Attributes -> Bool
protectedAttr forall s. TermStr s => Capability s
protectedOn
                            ]
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ \Attributes
a -> forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a -> b) -> a -> b
$ Attributes
a) [Attributes -> s]
cs

                                     

-- | These attributes have all properties turned off.
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

-- | Sound the audible bell.
bell :: TermStr s => Capability s
bell :: forall s. TermStr s => Capability s
bell = forall f. OutputCap f => String -> Capability f
tiGetOutput1 String
"bel"

-- | Present a visual alert using the @flash@ capability.
visualBell :: Capability TermOutput
visualBell :: Capability TermOutput
visualBell = forall f. OutputCap f => String -> Capability f
tiGetOutput1 String
"flash"