{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances, FlexibleContexts, PatternGuards, DeriveDataTypeable #-}

module ConfigurableBorders ( configureBorders
                           , configBorderWidth
                           , resetBorderWidth
                           , doConfigBorderWidth
                           , doConfigBorderOff
                           ) where


import qualified XMonad.Core as XM
import XMonad.Operations (sendMessage)
import XMonad.Layout.LayoutModifier (LayoutModifier(..), ModifiedLayout(..))
import Graphics.X11.Types (Window)
import Graphics.X11.Xlib.Types (Dimension)
import Graphics.X11.Xlib.Window (setWindowBorderWidth)

import Control.Monad.Reader

import Data.Monoid
import Data.Typeable
import qualified Data.Map as M
import qualified Data.Set as S


defaultBorderWidth :: XM.X Dimension
defaultBorderWidth = asks (XM.borderWidth . XM.config)


data BorderWidth = BorderWidth Window Dimension deriving Typeable

instance XM.Message BorderWidth


configBorderWidth :: Dimension -> Window -> XM.X ()
configBorderWidth w win = sendMessage $ BorderWidth win w

resetBorderWidth :: Window -> XM.X ()
resetBorderWidth win = do
  defBW <- defaultBorderWidth
  configBorderWidth defBW win

doConfigBorderWidth :: Dimension -> XM.ManageHook
doConfigBorderWidth w = XM.Query $ do
                        win <- ask
                        lift $ configBorderWidth w win
                        return $ Endo id

doConfigBorderOff :: XM.ManageHook
doConfigBorderOff = doConfigBorderWidth 0


data ConfigureBorders a = ConfigureBorders (M.Map a Dimension) (M.Map a Dimension)
                          deriving (Show, Read)

configureBorders :: (XM.LayoutClass l a) =>
                    l a
                 -> ModifiedLayout ConfigureBorders l a
configureBorders = ModifiedLayout $ ConfigureBorders M.empty M.empty


instance LayoutModifier ConfigureBorders Window where
    modifierDescription _ = "ConfigureBorders"
                            
    pureMess (ConfigureBorders wm wmlast) m
        | Just (BorderWidth win width) <- XM.fromMessage m = do
                                                  let wmnew = M.insert win width wm
                                                  return $ ConfigureBorders wmnew wmlast

    pureMess _ _ = Nothing
    
    redoLayout (ConfigureBorders wm wmlast) _ _ wrs = do
      setBorders wmlast
      return (wrs, Just $ ConfigureBorders M.empty wm)
        where
          ws = S.fromList $ map fst wrs


setBorders :: (M.Map Window Dimension) -> XM.X ()
setBorders wm = forM_ (M.toList wm) $ \(win,width) -> setBorder win width


setBorder :: Window -> Dimension -> XM.X ()
setBorder w width = XM.withDisplay $ \dpy -> XM.io $ setWindowBorderWidth dpy w width