{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
-- |
-- 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, when)
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\/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]
(Int -> ReadS ShowText)
-> ReadS [ShowText]
-> ReadPrec ShowText
-> ReadPrec [ShowText]
-> Read 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
(Int -> ShowText -> ShowS)
-> (ShowText -> String) -> ([ShowText] -> ShowS) -> Show ShowText
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 Map Atom Atom
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 (Map Atom Atom -> ShowText) -> Map Atom Atom -> 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 :: String -> String -> String -> ShowTextConfig
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 EventType
_ CULong
_ Bool
_ Display
dis Atom
_ Atom
mtyp [CInt]
d) = do
    (ShowText Map Atom Atom
m) <- X ShowText
forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
ES.get :: X ShowText
    Atom
a <- IO Atom -> X Atom
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO Atom -> X Atom) -> IO Atom -> X Atom
forall a b. (a -> b) -> a -> b
$ Display -> String -> Bool -> IO Atom
internAtom Display
dis String
"XMONAD_TIMER" Bool
False
    Bool -> X () -> X ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Atom
mtyp Atom -> Atom -> Bool
forall a. Eq a => a -> a -> Bool
== Atom
a Bool -> Bool -> Bool
&& Bool -> Bool
not ([CInt] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CInt]
d))
         (Maybe Atom -> (Atom -> X ()) -> X ()
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenJust (Atom -> Map Atom Atom -> Maybe Atom
forall k a. Ord k => k -> Map k a -> Maybe a
lookup (CInt -> Atom
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CInt -> Atom) -> CInt -> Atom
forall a b. (a -> b) -> a -> b
$ [CInt] -> CInt
forall a. [a] -> a
head [CInt]
d) Map Atom Atom
m) Atom -> X ()
deleteWindow)
    X All
forall a. Monoid a => a
mempty
handleTimerEvent Event
_ = X All
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 <- (XConf -> Display) -> X Display
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Display
display
  EventType
sc <- (XState -> EventType) -> X EventType
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((XState -> EventType) -> X EventType)
-> (XState -> EventType) -> X EventType
forall a b. (a -> b) -> a -> b
$ ScreenId -> EventType
forall a b. (Integral a, Num b) => a -> b
fi (ScreenId -> EventType)
-> (XState -> ScreenId) -> XState -> EventType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Screen String (Layout Atom) Atom ScreenId ScreenDetail -> ScreenId
forall i l a sid sd. Screen i l a sid sd -> sid
screen (Screen String (Layout Atom) Atom ScreenId ScreenDetail
 -> ScreenId)
-> (XState
    -> Screen String (Layout Atom) Atom ScreenId ScreenDetail)
-> XState
-> ScreenId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StackSet String (Layout Atom) Atom ScreenId ScreenDetail
-> Screen String (Layout Atom) Atom ScreenId ScreenDetail
forall i l a sid sd. StackSet i l a sid sd -> Screen i l a sid sd
current (StackSet String (Layout Atom) Atom ScreenId ScreenDetail
 -> Screen String (Layout Atom) Atom ScreenId ScreenDetail)
-> (XState
    -> StackSet String (Layout Atom) Atom ScreenId ScreenDetail)
-> XState
-> Screen String (Layout Atom) Atom ScreenId ScreenDetail
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XState -> StackSet String (Layout Atom) Atom ScreenId ScreenDetail
windowset
  Int
width <- Display -> XMonadFont -> String -> X Int
forall (m :: * -> *).
MonadIO m =>
Display -> XMonadFont -> String -> m Int
textWidthXMF Display
d XMonadFont
f String
s
  (Int32
as,Int32
ds) <- XMonadFont -> String -> X (Int32, Int32)
forall (m :: * -> *).
MonadIO m =>
XMonadFont -> String -> m (Int32, Int32)
textExtentsXMF XMonadFont
f String
s
  let hight :: Int32
hight = Int32
as Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
+ Int32
ds
      ht :: CInt
ht    = Display -> EventType -> CInt
displayHeight Display
d EventType
sc
      wh :: CInt
wh    = Display -> EventType -> CInt
displayWidth Display
d EventType
sc
      y :: Int32
y     = (CInt -> Int32
forall a b. (Integral a, Num b) => a -> b
fi CInt
ht Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
- Int32
hight Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
+ Int32
2) Int32 -> Int32 -> Int32
forall a. Integral a => a -> a -> a
`div` Int32
2
      x :: Int
x     = (CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fi CInt
wh Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
width Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2
  Atom
w <- Rectangle -> Maybe Atom -> String -> Bool -> X Atom
createNewWindow (Int32 -> Int32 -> EventType -> EventType -> Rectangle
Rectangle (Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fi Int
x) (Int32 -> Int32
forall a b. (Integral a, Num b) => a -> b
fi Int32
y) (Int -> EventType
forall a b. (Integral a, Num b) => a -> b
fi Int
width) (Int32 -> EventType
forall a b. (Integral a, Num b) => a -> b
fi Int32
hight))
                      Maybe Atom
forall a. Maybe a
Nothing String
"" Bool
True
  Atom -> X ()
showWindow Atom
w
  Atom
-> XMonadFont
-> EventType
-> EventType
-> EventType
-> String
-> String
-> String
-> String
-> [Align]
-> [String]
-> X ()
paintAndWrite Atom
w XMonadFont
f (Int -> EventType
forall a b. (Integral a, Num b) => a -> b
fi Int
width) (Int32 -> EventType
forall a b. (Integral a, Num b) => a -> b
fi Int32
hight) EventType
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
  IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> X ()) -> IO () -> X ()
forall a b. (a -> b) -> a -> b
$ Display -> Bool -> IO ()
sync Display
d Bool
False
  Int
t <- Rational -> X Int
startTimer Rational
i
  (ShowText -> ShowText) -> X ()
forall a (m :: * -> *).
(ExtensionClass a, XLike m) =>
(a -> a) -> m ()
ES.modify ((ShowText -> ShowText) -> X ()) -> (ShowText -> ShowText) -> X ()
forall a b. (a -> b) -> a -> b
$ (Map Atom Atom -> Map Atom Atom) -> ShowText -> ShowText
modShowText (Atom -> Atom -> Map Atom Atom -> Map Atom Atom
forall k a. Ord k => k -> a -> Map k a -> Map k a
insert (Int -> Atom
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
t) Atom
w)