    {-# 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
    --
    -- This layout modifier will allow to resize windows by dragging their
    -- borders with the mouse. However, it only works in layouts or modified
    -- layouts that react to the 'SetGeometry' message.
    -- "XMonad.Layout.WindowArranger" can be used to create such a setup,
    -- but it is probably must useful in a floating layout such as
    -- "XMonad.Layout.PositionStoreFloat" with which it has been mainly tested.
    -- See the documentation of PositionStoreFloat for a typical usage example.
    --
    -----------------------------------------------------------------------------

    module XMonad.Layout.BorderResize
        ( -- * Usage
          -- $usage
          borderResize
        , BorderResize (..)
        , RectWithBorders, BorderInfo,
        ) where

    import XMonad
    import XMonad.Layout.Decoration
    import XMonad.Layout.WindowArranger
    import XMonad.Util.XUtils
    import Control.Monad(when)
    import qualified Data.Map as M

    -- $usage
    -- You can use this module with the following in your
    -- @~\/.xmonad\/xmonad.hs@:
    --
    -- > import XMonad.Layout.BorderResize
    -- > myLayout = borderResize (... layout setup that reacts to SetGeometry ...)
    -- > main = xmonad def { layoutHook = myLayout }
    --

    type BorderBlueprint = (Rectangle, Glyph, BorderType)

    data BorderType = RightSideBorder
                        | LeftSideBorder
                        | TopSideBorder
                        | BottomSideBorder
                        deriving (Show, Read, Eq)
    data BorderInfo = BI { bWin :: Window,
                            bRect :: Rectangle,
                            bType :: BorderType
                         } deriving (Show, Read)

    type RectWithBorders = (Rectangle, [BorderInfo])

    data BorderResize a = BR (M.Map Window RectWithBorders) deriving (Show, Read)

    brBorderSize :: Dimension
    brBorderSize = 2

    borderResize :: l a -> ModifiedLayout BorderResize l a
    borderResize = ModifiedLayout (BR M.empty)

    instance LayoutModifier BorderResize Window where
        redoLayout _       _ Nothing  wrs = return (wrs, Nothing)
        redoLayout (BR wrsLastTime) _ _ wrs = do
                let correctOrder = map fst wrs
                    wrsCurrent = M.fromList wrs
                    wrsGone = M.difference wrsLastTime wrsCurrent
                    wrsAppeared = M.difference wrsCurrent wrsLastTime
                    wrsStillThere = M.intersectionWith testIfUnchanged wrsLastTime wrsCurrent
                handleGone wrsGone
                wrsCreated <- handleAppeared wrsAppeared
                let wrsChanged = handleStillThere wrsStillThere
                    wrsThisTime = M.union wrsChanged wrsCreated
                return (compileWrs wrsThisTime correctOrder, Just $ BR wrsThisTime)
                -- 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.
            where
                testIfUnchanged entry@(rLastTime, _) rCurrent =
                    if rLastTime == rCurrent
                        then (Nothing, entry)
                        else (Just rCurrent, entry)

        handleMess (BR wrsLastTime) m
            | Just e <- fromMessage m :: Maybe Event =
                handleResize (createBorderLookupTable wrsLastTime) e >> return Nothing
            | Just _ <- fromMessage m :: Maybe LayoutMessages =
                handleGone wrsLastTime >> return (Just $ BR M.empty)
        handleMess _ _ = return Nothing

    compileWrs :: M.Map Window RectWithBorders -> [Window] -> [(Window, Rectangle)]
    compileWrs wrsThisTime correctOrder = let wrs = reorder (M.toList wrsThisTime) correctOrder
                                          in concat $ map compileWr wrs

    compileWr :: (Window, RectWithBorders) -> [(Window, Rectangle)]
    compileWr (w, (r, borderInfos)) =
        let borderWrs = for borderInfos $ \bi -> (bWin bi, bRect bi)
        in borderWrs ++ [(w, r)]

    handleGone :: M.Map Window RectWithBorders -> X ()
    handleGone wrsGone = mapM_ deleteWindow borderWins
        where
            borderWins = map bWin . concat . map snd . M.elems $ wrsGone

    handleAppeared :: M.Map Window Rectangle -> X (M.Map Window RectWithBorders)
    handleAppeared wrsAppeared = do
        let wrs = M.toList wrsAppeared
        wrsCreated <- mapM handleSingleAppeared wrs
        return $ M.fromList wrsCreated

    handleSingleAppeared :: (Window, Rectangle) -> X (Window, RectWithBorders)
    handleSingleAppeared (w, r) = do
        let borderBlueprints = prepareBorders r
        borderInfos <- mapM createBorder borderBlueprints
        return (w, (r, borderInfos))

    handleStillThere :: M.Map Window (Maybe Rectangle, RectWithBorders) -> M.Map Window RectWithBorders
    handleStillThere wrsStillThere = M.map handleSingleStillThere wrsStillThere

    handleSingleStillThere :: (Maybe Rectangle, RectWithBorders) -> RectWithBorders
    handleSingleStillThere (Nothing, entry) = entry
    handleSingleStillThere (Just rCurrent, (_, borderInfos)) = (rCurrent, updatedBorderInfos)
        where
            changedBorderBlueprints = prepareBorders rCurrent
            updatedBorderInfos = map updateBorderInfo . zip borderInfos $ changedBorderBlueprints
              -- assuming that the four borders are always in the same order

    updateBorderInfo :: (BorderInfo, BorderBlueprint) -> BorderInfo
    updateBorderInfo (borderInfo, (r, _, _)) = borderInfo { bRect = r }

    createBorderLookupTable :: M.Map Window RectWithBorders -> [(Window, (BorderType, Window, Rectangle))]
    createBorderLookupTable wrsLastTime = concat $ map processSingleEntry $ M.toList wrsLastTime
        where
            processSingleEntry :: (Window, RectWithBorders) -> [(Window, (BorderType, Window, Rectangle))]
            processSingleEntry (w, (r, borderInfos)) = for borderInfos $ \bi -> (bWin bi, (bType bi, w, r))

    prepareBorders :: Rectangle -> [BorderBlueprint]
    prepareBorders (Rectangle x y wh ht) =
        [((Rectangle (x + fi wh - fi brBorderSize) y brBorderSize ht), xC_right_side , RightSideBorder),
         ((Rectangle x y brBorderSize ht)                            , xC_left_side  , LeftSideBorder),
         ((Rectangle x y wh brBorderSize)                            , xC_top_side   , TopSideBorder),
         ((Rectangle x (y + fi ht - fi brBorderSize) wh brBorderSize), xC_bottom_side, BottomSideBorder)
        ]

    handleResize :: [(Window, (BorderType, Window, Rectangle))] -> Event -> X ()
    handleResize borders ButtonEvent { ev_window = ew, ev_event_type = et }
        | et == buttonPress, Just edge <- lookup ew borders =
        case edge of
            (RightSideBorder, hostWin, (Rectangle hx hy _ hht)) ->
                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)
            (LeftSideBorder, hostWin, (Rectangle hx hy hwh hht)) ->
                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)
            (TopSideBorder, hostWin, (Rectangle hx hy hwh hht)) ->
                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)
            (BottomSideBorder, hostWin, (Rectangle hx hy hwh _)) ->
                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)
    handleResize _ _ = return ()

    createBorder :: BorderBlueprint -> X (BorderInfo)
    createBorder (borderRect, borderCursor, borderType) = do
        borderWin <- createInputWindow borderCursor borderRect
        return BI { bWin = borderWin, bRect = borderRect, bType = borderType }

    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

    reorder :: (Eq a) => [(a, b)] -> [a] -> [(a, b)]
    reorder wrs order =
        let ordered = concat $ map (pickElem wrs) order
            rest = filter (\(w, _) -> not (w `elem` order)) wrs
        in ordered ++ rest
        where
            pickElem list e = case (lookup e list) of
                                    Just result -> [(e, result)]
                                    Nothing -> []