    {-# LANGUAGE DeriveDataTypeable, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, PatternGuards, TypeSynonymInstances #-}
    -----------------------------------------------------------------------------
    -- |
    -- Module      :  XMonad.Layout.Decoration
    -- Copyright   :  (c) 2007 Andrea Rossato
    -- License     :  BSD-style (see xmonad/LICENSE)
    --
    -- Maintainer  :  andrea.rossato@unibz.it
    -- Stability   :  unstable
    -- Portability :  unportable
    --
    -- A layout modifier and a class for easily creating decorated
    -- layouts.
    -----------------------------------------------------------------------------

    module XMonad.Layout.Decoration
        ( -- * Usage:
          -- $usage
          decoration
        , Theme (..), defaultTheme
        , Decoration
        , DecorationMsg (..)
        , DecorationStyle (..)
        , DefaultDecoration (..)
        , Shrinker (..), DefaultShrinker
        , shrinkText, CustomShrink ( CustomShrink ), shrinkWhile
        , isInStack, isVisible, isInvisible, isWithin, fi
        , findWindowByDecoration
        , module XMonad.Layout.LayoutModifier
        ) where

    import Control.Monad (when)
    import Data.Maybe
    import Data.List

    import XMonad
    import qualified XMonad.StackSet as W
    import XMonad.Hooks.UrgencyHook
    import XMonad.Layout.LayoutModifier
    import XMonad.Layout.WindowArranger (WindowArrangerMsg (..), diff, listFromList)
    import XMonad.Util.NamedWindows (getName)
    import XMonad.Util.Invisible
    import XMonad.Util.XUtils
    import XMonad.Util.Font

    -- $usage
    -- This module is intended for layout developers, who want to decorate
    -- their layouts. End users will not find here very much for them.
    --
    -- For examples of 'DecorationStyle' instances you can have a look at
    -- "XMonad.Layout.SimpleDecoration", "XMonad.Layout.Tabbed",
    -- "XMonad.Layout.DwmStyle", or "XMonad.Layout.TabBarDecoration".

    -- | A layout modifier that, with a 'Shrinker', a 'Theme', a
    -- 'DecorationStyle', and a layout, will decorate this layout
    -- according to the decoration style provided.
    --
    -- For some usage examples see "XMonad.Layout.DecorationMadness".
    decoration :: (DecorationStyle ds a, Shrinker s) => s -> Theme -> ds a
               -> l a -> ModifiedLayout (Decoration ds s) l a
    decoration s t ds = ModifiedLayout (Decoration (I Nothing) s t ds)

    -- | A 'Theme' is a record of colors, font etc., to customize a
    -- 'DecorationStyle'.
    --
    -- For a collection of 'Theme's see "XMonad.Util.Themes"
    data Theme =
        Theme { activeColor         :: String    -- ^ Color of the active window
              , inactiveColor       :: String    -- ^ Color of the inactive window
              , urgentColor         :: String    -- ^ Color of the urgent window
              , activeBorderColor   :: String    -- ^ Color of the border of the active window
              , inactiveBorderColor :: String    -- ^ Color of the border of the inactive window
              , urgentBorderColor   :: String    -- ^ Color of the border of the urgent window
              , activeTextColor     :: String    -- ^ Color of the text of the active window
              , inactiveTextColor   :: String    -- ^ Color of the text of the inactive window
              , urgentTextColor     :: String    -- ^ Color of the text of the urgent window
              , fontName            :: String    -- ^ Font name
              , decoWidth           :: Dimension -- ^ Maximum width of the decorations (if supported by the 'DecorationStyle')
              , decoHeight          :: Dimension -- ^ Height of the decorations
              } deriving (Show, Read)

    -- | The default xmonad 'Theme'.
    defaultTheme :: Theme
    defaultTheme =
        Theme { activeColor         = "#999999"
              , inactiveColor       = "#666666"
              , urgentColor         = "#FFFF00"
              , activeBorderColor   = "#FFFFFF"
              , inactiveBorderColor = "#BBBBBB"
              , urgentBorderColor   = "##00FF00"
              , activeTextColor     = "#FFFFFF"
              , inactiveTextColor   = "#BFBFBF"
              , urgentTextColor     = "#FF0000"
              , fontName            = "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*"
              , decoWidth           = 200
              , decoHeight          = 20
              }

    -- | A 'Decoration' layout modifier will handle 'SetTheme', a message
    -- to dynamically change the decoration 'Theme'.
    data DecorationMsg = SetTheme Theme deriving ( Typeable )
    instance Message DecorationMsg

    -- | The 'Decoration' state component, where the list of decorated
    -- window's is zipped with a list of decoration. A list of decoration
    -- is a list of tuples, a 'Maybe' 'Window' and a 'Maybe Rectangle'.
    -- The 'Window' will be displayed only if the rectangle is of type
    -- 'Just'.
    data DecorationState =
        DS { decos :: [(OrigWin,DecoWin)]
           , font  :: XMonadFont
           }
    type DecoWin = (Maybe Window, Maybe Rectangle)
    type OrigWin = (Window,Rectangle)

    -- | The 'Decoration' 'LayoutModifier'. This data type is an instance
    -- of the 'LayoutModifier' class. This data type will be passed,
    -- together with a layout, to the 'ModifiedLayout' type constructor
    -- to modify the layout by adding decorations according to a
    -- 'DecorationStyle'.
    data Decoration ds s a =
        Decoration (Invisible Maybe DecorationState) s Theme (ds a)
        deriving (Show, Read)

    -- | The 'DecorationStyle' class, defines methods used in the
    -- implementation of the 'Decoration' 'LayoutModifier' instance. A
    -- type instance of this class is passed to the 'Decoration' type in
    -- order to decorate a layout, by using these methods.
    class (Read (ds a), Show (ds a), Eq a) => DecorationStyle ds a where

        -- | The description that the 'Decoration' modifier will display.
        describeDeco :: ds a -> String
        describeDeco ds = show ds

        -- | Shrink the window's rectangle when applying a decoration.
        shrink :: ds a -> Rectangle -> Rectangle -> Rectangle
        shrink _ (Rectangle _ _ _ dh) (Rectangle x y w h) = Rectangle x (y + fi dh) w (h - dh)

        -- | The decoration event hook, where the
        -- 'decorationMouseFocusHook' and 'decorationMouseDragHook' are
        -- called. If you reimplement it those methods will not be
        -- called.
        decorationEventHook :: ds a -> DecorationState -> Event -> X ()
        decorationEventHook ds s e = do decorationMouseFocusHook  ds s e
                                        decorationMouseDragHook   ds s e

        -- | This method is called when the user clicks the pointer over
        -- the decoration.
        decorationMouseFocusHook :: ds a -> DecorationState -> Event -> X ()
        decorationMouseFocusHook _ s e = handleMouseFocusDrag False s e

        -- | This method is called when the user starts grabbing the
        -- decoration.
        decorationMouseDragHook :: ds a -> DecorationState -> Event -> X ()
        decorationMouseDragHook _ s e = handleMouseFocusDrag True s e

        -- | The pure version of the main method, 'decorate'.
        pureDecoration :: ds a -> Dimension -> Dimension -> Rectangle
                       -> W.Stack a -> [(a,Rectangle)] -> (a,Rectangle) -> Maybe Rectangle
        pureDecoration _ _ ht _ s _ (w,Rectangle x y wh _) = if isInStack s w
                                                             then Just $ Rectangle x y wh ht
                                                             else Nothing

        -- | Given the theme's decoration width and height, the screen
        -- rectangle, the windows stack, the list of windows and
        -- rectangles returned by the underlying layout and window to be
        -- decorated, tupled with its rectangle, produce a 'Just'
        -- 'Rectangle' or 'Nothing' if the window is not to be decorated.
        decorate :: ds a -> Dimension -> Dimension -> Rectangle
                 -> W.Stack a -> [(a,Rectangle)] -> (a,Rectangle) -> X (Maybe Rectangle)
        decorate ds w h r s wrs wr = return $ pureDecoration ds w h r s wrs wr

    -- | The default 'DecorationStyle', with just the default methods'
    -- implementations.
    data DefaultDecoration a = DefaultDecoration deriving ( Read, Show )
    instance Eq a => DecorationStyle DefaultDecoration a

    -- | The long 'LayoutModifier' instance for the 'Decoration' type.
    --
    -- In 'redoLayout' we check the state: if there is no state we
    -- initialize it.
    --
    -- The state is 'diff'ed against the list of windows produced by the
    -- underlying layout: removed windows get deleted and new ones
    -- decorated by 'createDecos', which will call 'decorate' to decide if
    -- a window must be given a 'Rectangle', in which case a decoration
    -- window will be created.
    --
    -- After that we resync the updated state with the windows' list and
    -- then we process the resynced stated (as we do with a new state).
    --
    -- First we map the decoration windows, we update each decoration to
    -- reflect any decorated window's change, and we insert, in the list
    -- of windows and rectangles returned by the underlying layout, the
    -- decoration for each window. This way xmonad will restack the
    -- decorations and their windows accordingly. At the end we remove
    -- invisible\/stacked windows.
    --
    -- Message handling is quite simple: when needed we release the state
    -- component of the 'Decoration' 'LayoutModifier'. Otherwise we call
    -- 'handleEvent', which will call the appropriate 'DecorationStyle'
    -- methods to perform its tasks.
    instance (DecorationStyle ds Window, Shrinker s) => LayoutModifier (Decoration ds s) Window where
        redoLayout (Decoration (I (Just s)) sh t ds) _ Nothing _ = do
            releaseResources s
            return ([], Just $ Decoration (I Nothing) sh t ds)
        redoLayout _                                 _ Nothing _  = return ([], Nothing)

        redoLayout (Decoration st sh t ds) sc (Just stack) wrs
            | I Nothing  <- st = initState t ds sc stack wrs >>= processState
            | I (Just s) <- st = do let dwrs  = decos s
                                        (d,a) = curry diff (get_ws dwrs) ws
                                        toDel = todel d dwrs
                                        toAdd = toadd a wrs
                                    deleteDecos (map snd toDel)
                                    let ndwrs = zip toAdd $ repeat (Nothing,Nothing)
                                    ndecos <- resync (ndwrs ++ del_dwrs d dwrs) wrs
                                    processState (s {decos = ndecos })
            | otherwise        = return (wrs, Nothing)

            where
              ws        = map fst wrs
              get_w     = fst . fst
              get_ws    = map get_w
              del_dwrs  = listFromList get_w notElem
              find_dw i = fst . snd . flip (!!) i
              todel   d = filter (flip elem d . get_w)
              toadd   a = filter (flip elem a . fst  )

              check_dwr dwr = case dwr of
                                (Nothing, Just dr) -> do dw <- createDecoWindow t dr
                                                         return (Just dw, Just dr)
                                _                 -> return dwr

              resync _         [] = return []
              resync d ((w,r):xs) = case  w `elemIndex` get_ws d of
                                      Just i  -> do dr   <- decorate ds (decoWidth t) (decoHeight t) sc stack wrs (w,r)
                                                    dwr  <- check_dwr (find_dw i d, dr)
                                                    dwrs <- resync d xs
                                                    return $ ((w,r),dwr) : dwrs
                                      Nothing -> resync d xs

              -- We drop any windows that are *precisely* stacked underneath
              -- another window: these must be intended to be tabbed!
              remove_stacked rs ((w,r):xs)
                  | r `elem` rs   = remove_stacked rs xs
                  | otherwise     = (w,r) : remove_stacked (r:rs) xs
              remove_stacked _ [] = []

              insert_dwr ((w,r),(Just dw,Just dr)) xs = (dw,dr):(w, shrink ds dr r):xs
              insert_dwr (x    ,(     _ ,     _ )) xs = x:xs

              dwrs_to_wrs    = remove_stacked [] . foldr insert_dwr []

              processState s = do let ndwrs = decos s
                                  showDecos (map snd ndwrs)
                                  updateDecos sh t (font s) ndwrs
                                  return (dwrs_to_wrs ndwrs, Just (Decoration (I (Just (s {decos = ndwrs}))) sh t ds))

        handleMess (Decoration (I (Just s@(DS {decos = dwrs}))) sh t ds) m
            | Just e <- fromMessage m                = do decorationEventHook ds s e
                                                          handleEvent sh t s e
                                                          return Nothing
            | Just Hide             <- fromMessage m = do hideDecos (map snd dwrs)
                                                          return Nothing
            | Just (SetTheme nt)    <- fromMessage m = do releaseResources s
                                                          return $ Just $ Decoration (I Nothing) sh nt ds
            | Just ReleaseResources <- fromMessage m = do releaseResources s
                                                          return $ Just $ Decoration (I Nothing) sh t  ds
        handleMess _ _ = return Nothing

        modifierDescription (Decoration _ _ _ ds) = describeDeco ds

    -- | By default 'Decoration' handles 'PropertyEvent' and 'ExposeEvent'
    -- only.
    handleEvent :: Shrinker s => s -> Theme -> DecorationState -> Event -> X ()
    handleEvent sh t (DS dwrs fs) e
        | PropertyEvent {ev_window = w} <- e
        , Just i <- w `elemIndex`             (map (fst . fst) dwrs) = updateDeco sh t fs (dwrs !! i)
        | ExposeEvent   {ev_window = w} <- e
        , Just i <- w `elemIndex` (catMaybes $ map (fst . snd) dwrs) = updateDeco sh t fs (dwrs !! i)
    handleEvent _ _ _ _ = return ()

    -- | Mouse focus and mouse drag are handled by the same function, this
    -- way we can start dragging unfocused windows too.
    handleMouseFocusDrag :: Bool -> DecorationState -> Event -> X ()
    handleMouseFocusDrag b (DS dwrs _) ButtonEvent { ev_window     = ew
                                                   , ev_event_type = et
                                                   , ev_x_root     = ex
                                                   , ev_y_root     = ey }
        | et == buttonPress
        , Just ((mainw,r),_) <- lookFor ew dwrs = do
                                  focus mainw
                                  when b $ mouseDrag (\x y -> do
                                                        let rect = Rectangle (x - (fi ex - rect_x r))
                                                                             (y - (fi ey - rect_y r))
                                                                             (rect_width  r)
                                                                             (rect_height r)
                                                        sendMessage (SetGeometry rect)) (return ())
    handleMouseFocusDrag _ _ _ = return ()

    -- | Given a window and the state, if a matching decoration is in the
    -- state return it with its ('Maybe') 'Rectangle'.
    lookFor :: Window -> [(OrigWin,DecoWin)] -> Maybe (OrigWin,(Window,Maybe Rectangle))
    lookFor w ((wr,(Just dw,dr)):dwrs) | w == dw = Just (wr,(dw,dr))
                                       | otherwise = lookFor w dwrs
    lookFor w ((_, (Nothing, _)):dwrs) = lookFor w dwrs
    lookFor _ [] = Nothing

    findWindowByDecoration :: Window -> DecorationState -> Maybe (OrigWin,(Window,Maybe Rectangle))
    findWindowByDecoration w ds = lookFor w (decos ds)

    -- | Initialize the 'DecorationState' by initializing the font
    -- structure and by creating the needed decorations.
    initState :: DecorationStyle ds Window => Theme -> ds Window -> Rectangle
              -> W.Stack Window -> [(Window,Rectangle)] -> X DecorationState
    initState t ds sc s wrs = do
      fs   <- initXMF (fontName t)
      dwrs <- createDecos t ds sc s wrs wrs
      return $ DS dwrs fs

    -- | Delete windows stored in the state and release the font structure.
    releaseResources :: DecorationState -> X ()
    releaseResources s = do
      deleteDecos (map snd $ decos s)
      releaseXMF  (font s)

    -- | Create the decoration windows of a list of windows and their
    -- rectangles, by calling the 'decorate' method of the
    -- 'DecorationStyle' received.
    createDecos :: DecorationStyle ds Window => Theme -> ds Window -> Rectangle -> W.Stack Window
                -> [(Window,Rectangle)] -> [(Window,Rectangle)] -> X [(OrigWin,DecoWin)]
    createDecos t ds sc s wrs ((w,r):xs) = do
      deco <- decorate ds (decoWidth t) (decoHeight t) sc s wrs (w,r)
      case deco of
        Just dr -> do dw   <- createDecoWindow t dr
                      dwrs <- createDecos t ds sc s wrs xs
                      return $ ((w,r), (Just dw, Just dr)) : dwrs
        Nothing -> do dwrs <- createDecos t ds sc s wrs xs
                      return $ ((w,r), (Nothing, Nothing)) : dwrs
    createDecos _ _ _ _ _ [] = return []

    createDecoWindow :: Theme -> Rectangle -> X Window
    createDecoWindow t r = let mask = Just (exposureMask .|. buttonPressMask) in
                           createNewWindow r mask (inactiveColor t) True

    showDecos :: [DecoWin] -> X ()
    showDecos = showWindows . catMaybes . map fst

    hideDecos :: [DecoWin] -> X ()
    hideDecos = hideWindows . catMaybes . map fst

    deleteDecos :: [DecoWin] -> X ()
    deleteDecos = deleteWindows . catMaybes . map fst

    updateDecos :: Shrinker s => s -> Theme -> XMonadFont -> [(OrigWin,DecoWin)] -> X ()
    updateDecos s t f = mapM_ $ updateDeco s t f

    -- | Update a decoration window given a shrinker, a theme, the font
    -- structure and the needed 'Rectangle's
    updateDeco :: Shrinker s => s -> Theme -> XMonadFont -> (OrigWin,DecoWin) -> X ()
    updateDeco sh t fs ((w,_),(Just dw,Just (Rectangle _ _ wh ht))) = do
      nw  <- getName w
      ur  <- readUrgents
      dpy <- asks display
      let focusColor win ic ac uc = (maybe ic (\focusw -> case () of
                                                           _ | focusw == win -> ac
                                                             | win `elem` ur -> uc
                                                             | otherwise     -> ic) . W.peek)
                                    `fmap` gets windowset
      (bc,borderc,tc) <- focusColor w (inactiveColor t, inactiveBorderColor t, inactiveTextColor t)
                                      (activeColor   t, activeBorderColor   t, activeTextColor   t)
                                      (urgentColor   t, urgentBorderColor   t, urgentTextColor   t)
      let s = shrinkIt sh
      name <- shrinkWhile s (\n -> do size <- io $ textWidthXMF dpy fs n
                                      return $ size > fromIntegral wh - fromIntegral (ht `div` 2)) (show nw)
      paintAndWrite dw fs wh ht 1 bc borderc tc bc AlignCenter name
    updateDeco _ _ _ (_,(Just w,Nothing)) = hideWindow w
    updateDeco _ _ _ _ = return ()

    -- | True if the window is in the 'Stack'. The 'Window' comes second
    -- to facilitate list processing, even though @w \`isInStack\` s@ won't
    -- work...;)
    isInStack :: Eq a => W.Stack a -> a -> Bool
    isInStack s = flip elem (W.integrate s)

    -- | Given a 'Rectangle' and a list of 'Rectangle's is True if the
    -- 'Rectangle' is not completely contained by any 'Rectangle' of the
    -- list.
    isVisible :: Rectangle -> [Rectangle] -> Bool
    isVisible r = and . foldr f []
        where f x xs = if r `isWithin` x then False : xs else True : xs

    -- | The contrary of 'isVisible'.
    isInvisible :: Rectangle -> [Rectangle] -> Bool
    isInvisible r = not . isVisible r

    -- | True is the first 'Rectangle' is totally within the second
    -- 'Rectangle'.
    isWithin :: Rectangle -> Rectangle -> Bool
    isWithin (Rectangle x y w h) (Rectangle rx ry rw rh)
        | x >= rx, x <= rx + fi rw
        , y >= ry, y <= ry + fi rh
        , x + fi w <= rx + fi rw
        , y + fi h <= ry + fi rh = True
        | otherwise              = False

    shrinkWhile :: (String -> [String]) -> (String -> X Bool) -> String -> X String
    shrinkWhile sh p x = sw $ sh x
        where sw [n] = return n
              sw [] = return ""
              sw (n:ns) = do
                            cond <- p n
                            if cond
                              then sw ns
                              else return n

    data CustomShrink = CustomShrink
    instance Show CustomShrink where show _ = ""
    instance Read CustomShrink where readsPrec _ s = [(CustomShrink,s)]

    class (Read s, Show s) => Shrinker s where
        shrinkIt :: s -> String -> [String]

    data DefaultShrinker = DefaultShrinker
    instance Show DefaultShrinker where show _ = ""
    instance Read DefaultShrinker where readsPrec _ s = [(DefaultShrinker,s)]
    instance Shrinker DefaultShrinker where
        shrinkIt _ "" = [""]
        shrinkIt s cs = cs : shrinkIt s (init cs)

    shrinkText :: DefaultShrinker
    shrinkText = DefaultShrinker