{-# LANGUAGE TypeSynonymInstances, MultiParamTypeClasses, PatternGuards #-}
----------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Layout.BorderResize
-- Copyright   :  (c) Jan Vornberger 2009
-- License     :  BSD3-style (see LICENSE)
--
-- Maintainer  :  jan.vornberger@informatik.uni-oldenburg.de
-- Stability   :  unstable
-- Portability :  not portable
--
-----------------------------------------------------------------------------

module XMonad.Layout.BorderResize
    ( borderResize
    , BorderResize (..)
    ) where

import XMonad
import XMonad.Layout.Decoration
import XMonad.Layout.WindowArranger
import XMonad.Util.XUtils
import Control.Monad(when,forM)

data BorderInfo = RightSideBorder Window Rectangle
                    | LeftSideBorder Window Rectangle
                    | TopSideBorder Window Rectangle
                    | BottomSideBorder Window Rectangle
                    deriving (Show, Read, Eq)
type BorderWithRect = (Rectangle, Rectangle, Glyph, BorderInfo)
type BorderWithWin = (Window, BorderInfo)

data BorderResize a = BR [BorderWithWin] deriving (Show, Read)

brBorderOffset :: Position
brBorderOffset = 5
brBorderSize :: Dimension
brBorderSize = 10

brCursorRightSide :: Glyph
brCursorRightSide = 96
brCursorLeftSide :: Glyph
brCursorLeftSide = 70
brCursorTopSide :: Glyph
brCursorTopSide = 138
brCursorBottomSide :: Glyph
brCursorBottomSide = 16

borderResize :: l a -> ModifiedLayout BorderResize l a
borderResize = ModifiedLayout (BR [])

instance LayoutModifier BorderResize Window where
    redoLayout _       _ Nothing  wrs = return (wrs, Nothing)
    redoLayout (BR borders) _ _ wrs =
        let preparedBorders = for wrs $ \wr -> (wr, prepareBorders wr)
        in do
            mapM_ deleteBorder borders
            newBorders <- forM preparedBorders $ \(wr, (b1, b2, b3, b4)) -> do
                                (b1WR, b1BWW) <- createBorder b1
                                (b2WR, b2BWW) <- createBorder b2
                                (b3WR, b3BWW) <- createBorder b3
                                (b4WR, b4BWW) <- createBorder b4
                                return ([b1WR, b2WR, b3WR, b4WR, wr],
                                        [b1BWW, b2BWW, b3BWW, b4BWW])
            let wrs' = concat $ map fst newBorders
                newBordersSerialized = concat $ map snd newBorders
            return (wrs', Just $ BR newBordersSerialized)
                -- What we return is the original wrs with the new border
                -- windows inserted at the correct positions - this way, the core
                -- will restack the borders correctly.
                -- We also return information about our borders, so that we
                -- can handle events that they receive and destroy them when
                -- they are no longer needed.

    handleMess (BR borders) m
        | Just e <- fromMessage m :: Maybe Event = handleResize borders e >> return Nothing
        | Just Hide             <- fromMessage m = releaseResources >> return (Just $ BR [])
        | Just ReleaseResources <- fromMessage m = releaseResources >> return (Just $ BR [])
        where releaseResources = mapM_ deleteBorder borders
    handleMess _ _ = return Nothing

prepareBorders :: (Window, Rectangle) -> (BorderWithRect, BorderWithRect, BorderWithRect, BorderWithRect)
prepareBorders (w, r@(Rectangle x y wh ht)) =
    ((r, (Rectangle (x + fi wh - brBorderOffset) y brBorderSize ht) , brCursorRightSide     , RightSideBorder w r),
     (r, (Rectangle (x - brBorderOffset) y brBorderSize ht)         , brCursorLeftSide      , LeftSideBorder w r),
     (r, (Rectangle x (y - brBorderOffset) wh brBorderSize)         , brCursorTopSide       , TopSideBorder w r),
     (r, (Rectangle x (y + fi ht - brBorderOffset) wh brBorderSize) , brCursorBottomSide    , BottomSideBorder w r)
    )

handleResize :: [BorderWithWin] -> Event -> X ()
handleResize borders ButtonEvent { ev_window = ew, ev_event_type = et }
    | et == buttonPress = do
        case (lookup ew borders) of
            Just (RightSideBorder hostWin (Rectangle hx hy _ hht)) -> do
                mouseDrag (\x _ -> do
                             let nwh = max 1 $ fi (x - hx)
                                 rect = Rectangle hx hy nwh hht
                             focus hostWin
                             when (x - hx > 0) $ sendMessage (SetGeometry rect)) (focus hostWin)
            Just (LeftSideBorder hostWin (Rectangle hx hy hwh hht)) -> do
                mouseDrag (\x _ -> do
                             let nx = max 0 $ min (hx + fi hwh) $ x
                                 nwh = max 1 $ hwh + fi (hx - x)
                                 rect = Rectangle nx hy nwh hht
                             focus hostWin
                             when (x < hx + fi hwh) $ sendMessage (SetGeometry rect)) (focus hostWin)
            Just (TopSideBorder hostWin (Rectangle hx hy hwh hht)) -> do
                mouseDrag (\_ y -> do
                             let ny = max 0 $ min (hy + fi hht) $ y
                                 nht = max 1 $ hht + fi (hy - y)
                                 rect = Rectangle hx ny hwh nht
                             focus hostWin
                             when (y < hy + fi hht) $ sendMessage (SetGeometry rect)) (focus hostWin)
            Just (BottomSideBorder hostWin (Rectangle hx hy hwh _)) -> do
                mouseDrag (\_ y -> do
                             let nht = max 1 $ fi (y - hy)
                                 rect = Rectangle hx hy hwh nht
                             focus hostWin
                             when (y - hy > 0) $ sendMessage (SetGeometry rect)) (focus hostWin)
            Nothing -> return ()
handleResize _ _ = return ()

createBorder :: BorderWithRect -> X (((Window, Rectangle), BorderWithWin))
createBorder (_, borderRect, borderCursor, borderInfo) = do
    borderWin <- createInputWindow borderCursor borderRect
    return ((borderWin, borderRect), (borderWin, borderInfo))

deleteBorder :: BorderWithWin -> X ()
deleteBorder (borderWin, _) = deleteWindow borderWin

createInputWindow :: Glyph -> Rectangle -> X Window
createInputWindow cursorGlyph r = withDisplay $ \d -> do
    win <- mkInputWindow d r
    io $ selectInput d win (exposureMask .|. buttonPressMask)
    cursor <- io $ createFontCursor d cursorGlyph
    io $ defineCursor d win cursor
    io $ freeCursor d cursor
    showWindow win
    return win

mkInputWindow :: Display -> Rectangle -> X Window
mkInputWindow d (Rectangle x y w h) = do
  rw <- asks theRoot
  let screen   = defaultScreenOfDisplay d
      visual   = defaultVisualOfScreen screen
      attrmask = cWOverrideRedirect
  io $ allocaSetWindowAttributes $
         \attributes -> do
           set_override_redirect attributes True
           createWindow d rw x y w h 0 0 inputOnly visual attrmask attributes

for :: [a] -> (a -> b) -> [b]
for = flip map