{-# 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]
(Int -> ReadS ShowText)
-> ReadS [ShowText]
-> ReadPrec ShowText
-> ReadPrec [ShowText]
-> Read ShowText
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS ShowText
readsPrec :: Int -> ReadS ShowText
$creadList :: ReadS [ShowText]
readList :: ReadS [ShowText]
$creadPrec :: ReadPrec ShowText
readPrec :: ReadPrec ShowText
$creadListPrec :: ReadPrec [ShowText]
readListPrec :: ReadPrec [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
$cshowsPrec :: Int -> ShowText -> ShowS
showsPrec :: Int -> ShowText -> ShowS
$cshow :: ShowText -> String
show :: ShowText -> String
$cshowList :: [ShowText] -> ShowS
showList :: [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 { 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 m) <- X ShowText
forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
ES.get :: X ShowText
    a <- io $ internAtom dis "XMONAD_TIMER" False
    if | mtyp == a, Just dh <- listToMaybe d ->
           whenJust (lookup (fromIntegral dh) m) deleteWindow
       | otherwise -> pure ()
    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
  f <- String -> X XMonadFont
initXMF (ShowTextConfig -> String
st_font ShowTextConfig
c)
  d <- asks display
  sc <- gets $ fi . screen . current . windowset
  width <- textWidthXMF d f s
  (as,ds) <- textExtentsXMF f s
  let hight = Position
as Position -> Position -> Position
forall a. Num a => a -> a -> a
+ Position
ds
      ht    = Display -> ScreenNumber -> CInt
displayHeight Display
d ScreenNumber
sc
      wh    = Display -> ScreenNumber -> CInt
displayWidth Display
d ScreenNumber
sc
      y     = (CInt -> Position
forall a b. (Integral a, Num b) => a -> b
fi CInt
ht Position -> Position -> Position
forall a. Num a => a -> a -> a
- Position
hight Position -> Position -> Position
forall a. Num a => a -> a -> a
+ Position
2) Position -> Position -> Position
forall a. Integral a => a -> a -> a
`div` Position
2
      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
  w <- createNewWindow (Rectangle (fi x) (fi y) (fi width) (fi hight))
                      Nothing "" True
  showWindow w
  paintAndWrite w f (fi width) (fi hight) 0 (st_bg c) ""
                (st_fg c) (st_bg c) [AlignCenter] [s]
  releaseXMF f
  io $ sync d False
  t <- startTimer i
  ES.modify $ modShowText (insert (fromIntegral t) w)