{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, DeriveDataTypeable #-}

module MetaTile.Layout.Floating (
    Floating, floating,
    float, sink, mouseMoveWindow, mouseResizeWindow
    ) where

import Prelude hiding (Floating)

import MetaTile.Core
import MetaTile.Layout.LayoutModifier
import MetaTile.Operations
import qualified MetaTile.StackSet as W
import qualified MetaTile.Util.ExtensibleState as XS

import Control.Arrow ((&&&), first)
import Control.Monad.Reader
import Control.Monad.State
import Data.Functor
import qualified Data.Map as M
import Data.Maybe
import Graphics.X11.Xlib
import Graphics.X11.Xlib.Extras


data FloatingStorage = FloatingStorage {
    floatingWindows :: M.Map Window Rectangle
    } deriving (Show, Read, Typeable)

instance ExtensionClass FloatingStorage where
    initialValue = FloatingStorage M.empty
    extensionType = PersistentExtension


data Floating a = Floating deriving (Show, Read)

instance LayoutModifier Floating Window where
    modifyLayout _ (w@W.Workspace { W.stack = stack }) r = do
        bw <- asks (defaultBorderWidth . config)
        ws <- gets windowset
        FloatingStorage { floatingWindows = fw } <- XS.get
        let fw' = M.filterWithKey (\k _ -> k `W.member` ws) fw
            tiled = stack >>= W.filter (`M.notMember` fw')
            fwLayout = [(a, ar, bw) | (a, ar) <- catMaybes . map (maybeSecond . (id &&& flip M.lookup fw')) $ W.integrate' stack]
        XS.put $ FloatingStorage fw'
        first (fwLayout ++) <$> runBorderLayout (w { W.stack = tiled }) r
      where
        maybeSecond :: (a, Maybe b) -> Maybe (a, b)
        maybeSecond (a, Just b) = Just (a, b)
        maybeSecond (_, Nothing) = Nothing

floating :: l Window -> ModifiedLayout Floating l Window
floating = ModifiedLayout Floating


------------------------------------------------------------------------
-- | Floating layer support

-- | Given a window, find the screen it is located on, and compute
-- the geometry of that window wrt. that screen.
floatLocation :: Window -> X (ScreenId, Rectangle)
floatLocation w = withDisplay $ \d -> do
    ws <- gets windowset
    frame <- getsWindowState wsFrame w
    wa <- io $ getWindowAttributes d frame
    sc <- fromMaybe (W.current ws) <$> pointScreen (fi $ wa_x wa) (fi $ wa_y wa)
    let sr = screenRect . W.screenDetail $ sc
        rr = Rectangle ((fi $ wa_x wa) - (fi $ rect_x sr)) ((fi $ wa_y wa) - (fi $ rect_y sr)) (fi $ wa_width wa) (fi $ wa_height wa)
    return (W.screen sc, rr)
  where fi x = fromIntegral x

-- | Make a tiled window floating, using its suggested rectangle
float :: Window -> X ()
float w = do
    (_, r) <- floatLocation w
    XS.modify $ \(FloatingStorage fw) -> FloatingStorage (M.insert w r fw)
    refresh

-- | Clear the floating status of a window
sink :: Window -> X ()
sink w = do
    XS.modify $ \(FloatingStorage fw) -> FloatingStorage (M.delete w fw)
    refresh


-- | XXX comment me
mouseMoveWindow :: Window -> X ()
mouseMoveWindow w = whenX (isClient w) $ withDisplay $ \d -> do
    frame <- getsWindowState wsFrame w
    io $ raiseWindow d frame
    wa <- io $ getWindowAttributes d frame
    (_, _, _, ox', oy', _, _, _) <- io $ queryPointer d frame
    let ox = fromIntegral ox'
        oy = fromIntegral oy'
    mouseDrag (\ex ey -> (io $ moveWindow d frame (fromIntegral (fromIntegral (wa_x wa) + (ex - ox))) (fromIntegral (fromIntegral (wa_y wa) + (ey - oy)))) >> reveal w) (float w)

-- | XXX comment me
mouseResizeWindow :: Window -> X ()
mouseResizeWindow w = whenX (isClient w) $ withDisplay $ \d -> do
    frame <- getsWindowState wsFrame w
    io $ raiseWindow d frame
    wa <- io $ getWindowAttributes d frame
    sh <- io $ getWMNormalHints d w
    io $ warpPointer d none frame 0 0 0 0 (fromIntegral (wa_width wa)) (fromIntegral (wa_height wa))
    mouseDrag (\ex ey -> (io $ resizeWindow d frame `uncurry` applySizeHintsContents sh (ex - fromIntegral (wa_x wa), ey - fromIntegral (wa_y wa))) >> reveal w) (float w)