WorkspaceOverviewPopup.hs

{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
module WorkspaceOverviewPopup where

import Data.Maybe
import Control.Monad

import XMonad
import qualified XMonad.StackSet as W
import XMonad.Layout.LayoutModifier
import XMonad.Util.Font
import XMonad.Util.Timer
import XMonad.Util.XUtils

import XMonad.Hooks.DynamicLog

data WOPConfig = WOPConfig { wop_font        :: String
                           , wop_color       :: String
                           , wop_bgcolor     :: String
                           , wop_bordercolor :: String
                           , wop_fade        :: Rational
                           } deriving (Read, Show)

defaultWOPConfig :: WOPConfig
defaultWOPConfig = WOPConfig { wop_font        = "-misc-fixed-*-*-*-*-20-*-*-*-*-*-*-*"
                             , wop_color       = "white"
                             , wop_bgcolor     = "black"
                             , wop_bordercolor = "black"
                             , wop_fade        = 2
                             }

solarizedLightWOPConfig :: WOPConfig
solarizedLightWOPConfig = WOPConfig { wop_font        = "xft:Inconsolata:size=15"
                                    , wop_bgcolor = "gray"
                                    , wop_color   = "black"
                                    -- , wop_bgcolor     = "green"
                                    -- , wop_color       = "red"
                                    , wop_bordercolor = "blue"
                                    , wop_fade        = 2
                                    }

ppFun :: X String
ppFun = dynamicLogString defaultPP

type WinRects a = [(a, Rectangle)]
type WOPState = Maybe (TimerId, Window)
data WorkspaceOverviewPopup a = WOP { wop_hidden  :: Bool
                                    , wop_config  :: WOPConfig
                                    , wop_state   :: WOPState
                                    } deriving (Read, Show)

instance LayoutModifier WorkspaceOverviewPopup a where
    redoLayout wopm rect _wstack winrects = doShow wopm rect winrects

    handleMess (WOP _visible cfg (Just (tid, win))) msg
      | Just e <- fromMessage msg = handleTimer tid e $ do deleteWindow win
                                                           return Nothing

    handleMess (WOP _visible cfg state) msg
      | Just Hide <- fromMessage msg = return (Just (WOP True cfg state))
      | otherwise                    = return Nothing


doShow (WOP hidden cfg state) rect wrs = do
  when (isJust state) $ let win = snd (fromJust state) in deleteWindow win
  if hidden
    then displayDynamicLog cfg rect wrs
    else return (wrs, Nothing)


displayDynamicLog :: WOPConfig -> Rectangle -> [(a, Rectangle)] ->
                     X ([(a, Rectangle)], Maybe (WorkspaceOverviewPopup a))
displayDynamicLog cfg (Rectangle startx starty width height) winrects = do
  disp <- asks display
  font <- initXMF (wop_font cfg)
  str <- ppFun
  width' <- textWidthXMF disp font str
  (as, ds) <- textExtentsXMF font str
  let height' = as + ds
      x = fi startx + (fi width  - width'  + 2) `div` 2
      y = fi starty + (fi height - height' + 2) `div` 2
      rect' = Rectangle (fi x) (fi y) (fi width') (fi height')
  win <- createNewWindow rect' Nothing "" True
  showWindow win
  paintAndWrite win font (fi width') (fi height') 0
    "" (wop_bordercolor cfg) (wop_color cfg) (wop_bgcolor cfg)   [AlignCenter] [str]

  releaseXMF font
  io $ sync disp False
  tid <- startTimer (wop_fade cfg)
  return (winrects, Just $ WOP False cfg (Just (tid, win)))

workspaceOverview' :: WOPConfig -> l a -> ModifiedLayout WorkspaceOverviewPopup l a
workspaceOverview' cfg = ModifiedLayout (WOP True cfg Nothing)

workspaceOverview :: l a -> ModifiedLayout WorkspaceOverviewPopup l a
workspaceOverview = workspaceOverview' solarizedLightWOPConfig