{-# LANGUAGE CPP #-}
{-# LANGUAGE MultiWayIf #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Actions.ShowText
-- Description :  Display text on the screen.
-- Copyright   :  (c) Mario Pastorelli (2012)
-- License     :  BSD-style (see xmonad/LICENSE)
--
-- Maintainer  :  pastorelli.mario@gmail.com
-- Stability   :  unstable
-- Portability :  unportable
--
-- ShowText displays text for sometime on the screen similar to "XMonad.Util.Dzen"
-- which offers more features (currently)
-----------------------------------------------------------------------------

module XMonad.Actions.ShowText
    ( -- * Usage
      -- $usage
      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

-- $usage
-- You can use this module with the following in your @xmonad.hs@:
--
-- > import XMonad.Actions.ShowText
--
-- Then add the event hook handler:
--
-- > xmonad { handleEventHook = myHandleEventHooks <> handleTimerEvent }
--
-- You can then use flashText in your keybindings:
--
-- > ((modMask, xK_Right), flashText def 1 "->" >> nextWS)
--

-- | ShowText contains the map with timers as keys and created windows as values
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

-- | Utility to modify a ShowText
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 -- ^ Font name
        , ShowTextConfig -> String
st_bg   :: String -- ^ Background color
        , ShowTextConfig -> String
st_fg   :: String -- ^ Foreground color
    }

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"
    }

-- | Handles timer events that notify when a window should be removed
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

-- | Shows a window in the center of the screen with the given text
flashText :: ShowTextConfig
    -> Rational -- ^ number of seconds
    -> String -- ^ text to display
    -> 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)