{-# LANGUAGE CPP #-}
{-# LANGUAGE MultiWayIf #-}
module XMonad.Actions.ShowText
(
def
, handleTimerEvent
, flashText
, ShowTextConfig(..)
) where
import Data.Map (Map,empty,insert,lookup)
import Prelude hiding (lookup)
import XMonad
import XMonad.Prelude (All, fi, listToMaybe)
import XMonad.StackSet (current,screen)
import XMonad.Util.Font (Align(AlignCenter)
, initXMF
, releaseXMF
, textExtentsXMF
, textWidthXMF)
import XMonad.Util.Timer (startTimer)
import XMonad.Util.XUtils (createNewWindow
, deleteWindow
, showWindow
, paintAndWrite)
import qualified XMonad.Util.ExtensibleState as ES
newtype ShowText = ShowText (Map Atom Window)
deriving (ReadPrec [ShowText]
ReadPrec ShowText
Int -> ReadS ShowText
ReadS [ShowText]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [ShowText]
$creadListPrec :: ReadPrec [ShowText]
readPrec :: ReadPrec ShowText
$creadPrec :: ReadPrec ShowText
readList :: ReadS [ShowText]
$creadList :: ReadS [ShowText]
readsPrec :: Int -> ReadS ShowText
$creadsPrec :: Int -> ReadS ShowText
Read,Int -> ShowText -> ShowS
[ShowText] -> ShowS
ShowText -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ShowText] -> ShowS
$cshowList :: [ShowText] -> ShowS
show :: ShowText -> String
$cshow :: ShowText -> String
showsPrec :: Int -> ShowText -> ShowS
$cshowsPrec :: Int -> ShowText -> ShowS
Show)
instance ExtensionClass ShowText where
initialValue :: ShowText
initialValue = Map Atom Atom -> ShowText
ShowText forall k a. Map k a
empty
modShowText :: (Map Atom Window -> Map Atom Window) -> ShowText -> ShowText
modShowText :: (Map Atom Atom -> Map Atom Atom) -> ShowText -> ShowText
modShowText Map Atom Atom -> Map Atom Atom
f (ShowText Map Atom Atom
m) = Map Atom Atom -> ShowText
ShowText forall a b. (a -> b) -> a -> b
$ Map Atom Atom -> Map Atom Atom
f Map Atom Atom
m
data ShowTextConfig =
STC { ShowTextConfig -> String
st_font :: String
, ShowTextConfig -> String
st_bg :: String
, ShowTextConfig -> String
st_fg :: String
}
instance Default ShowTextConfig where
def :: ShowTextConfig
def =
#ifdef XFT
STC { st_font :: String
st_font = String
"xft:monospace-20"
#else
STC { st_font = "-misc-fixed-*-*-*-*-20-*-*-*-*-*-*-*"
#endif
, st_bg :: String
st_bg = String
"black"
, st_fg :: String
st_fg = String
"white"
}
handleTimerEvent :: Event -> X All
handleTimerEvent :: Event -> X All
handleTimerEvent (ClientMessageEvent ScreenNumber
_ CULong
_ Bool
_ Display
dis Atom
_ Atom
mtyp [CInt]
d) = do
(ShowText Map Atom Atom
m) <- forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
ES.get :: X ShowText
Atom
a <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ Display -> String -> Bool -> IO Atom
internAtom Display
dis String
"XMONAD_TIMER" Bool
False
if | Atom
mtyp forall a. Eq a => a -> a -> Bool
== Atom
a, Just CInt
dh <- forall a. [a] -> Maybe a
listToMaybe [CInt]
d ->
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenJust (forall k a. Ord k => k -> Map k a -> Maybe a
lookup (forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
dh) Map Atom Atom
m) Atom -> X ()
deleteWindow
| Bool
otherwise -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
forall a. Monoid a => a
mempty
handleTimerEvent Event
_ = forall a. Monoid a => a
mempty
flashText :: ShowTextConfig
-> Rational
-> String
-> X ()
flashText :: ShowTextConfig -> Rational -> String -> X ()
flashText ShowTextConfig
c Rational
i String
s = do
XMonadFont
f <- String -> X XMonadFont
initXMF (ShowTextConfig -> String
st_font ShowTextConfig
c)
Display
d <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Display
display
ScreenNumber
sc <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fi forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall i l a sid sd. Screen i l a sid sd -> sid
screen forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall i l a sid sd. StackSet i l a sid sd -> Screen i l a sid sd
current forall b c a. (b -> c) -> (a -> b) -> a -> c
. XState -> WindowSet
windowset
Int
width <- forall (m :: * -> *).
MonadIO m =>
Display -> XMonadFont -> String -> m Int
textWidthXMF Display
d XMonadFont
f String
s
(Position
as,Position
ds) <- forall (m :: * -> *).
MonadIO m =>
XMonadFont -> String -> m (Position, Position)
textExtentsXMF XMonadFont
f String
s
let hight :: Position
hight = Position
as forall a. Num a => a -> a -> a
+ Position
ds
ht :: CInt
ht = Display -> ScreenNumber -> CInt
displayHeight Display
d ScreenNumber
sc
wh :: CInt
wh = Display -> ScreenNumber -> CInt
displayWidth Display
d ScreenNumber
sc
y :: Position
y = (forall a b. (Integral a, Num b) => a -> b
fi CInt
ht forall a. Num a => a -> a -> a
- Position
hight forall a. Num a => a -> a -> a
+ Position
2) forall a. Integral a => a -> a -> a
`div` Position
2
x :: Int
x = (forall a b. (Integral a, Num b) => a -> b
fi CInt
wh forall a. Num a => a -> a -> a
- Int
width forall a. Num a => a -> a -> a
+ Int
2) forall a. Integral a => a -> a -> a
`div` Int
2
Atom
w <- Rectangle -> Maybe Atom -> String -> Bool -> X Atom
createNewWindow (Position -> Position -> ScreenNumber -> ScreenNumber -> Rectangle
Rectangle (forall a b. (Integral a, Num b) => a -> b
fi Int
x) (forall a b. (Integral a, Num b) => a -> b
fi Position
y) (forall a b. (Integral a, Num b) => a -> b
fi Int
width) (forall a b. (Integral a, Num b) => a -> b
fi Position
hight))
forall a. Maybe a
Nothing String
"" Bool
True
Atom -> X ()
showWindow Atom
w
Atom
-> XMonadFont
-> ScreenNumber
-> ScreenNumber
-> ScreenNumber
-> String
-> String
-> String
-> String
-> [Align]
-> [String]
-> X ()
paintAndWrite Atom
w XMonadFont
f (forall a b. (Integral a, Num b) => a -> b
fi Int
width) (forall a b. (Integral a, Num b) => a -> b
fi Position
hight) ScreenNumber
0 (ShowTextConfig -> String
st_bg ShowTextConfig
c) String
""
(ShowTextConfig -> String
st_fg ShowTextConfig
c) (ShowTextConfig -> String
st_bg ShowTextConfig
c) [Align
AlignCenter] [String
s]
XMonadFont -> X ()
releaseXMF XMonadFont
f
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ Display -> Bool -> IO ()
sync Display
d Bool
False
Int
t <- Rational -> X Int
startTimer Rational
i
forall a (m :: * -> *).
(ExtensionClass a, XLike m) =>
(a -> a) -> m ()
ES.modify forall a b. (a -> b) -> a -> b
$ (Map Atom Atom -> Map Atom Atom) -> ShowText -> ShowText
modShowText (forall k a. Ord k => k -> a -> Map k a -> Map k a
insert (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
t) Atom
w)