    {-# LANGUAGE TypeSynonymInstances, MultiParamTypeClasses, PatternGuards #-}
    ----------------------------------------------------------------------------
    -- |
    -- Module      :  XMonad.Layout.PositionStoreFloat
    -- Copyright   :  (c) Jan Vornberger 2009
    -- License     :  BSD3-style (see LICENSE)
    --
    -- Maintainer  :  jan.vornberger@informatik.uni-oldenburg.de
    -- Stability   :  unstable
    -- Portability :  not portable
    --
    -- A floating layout which has been designed with a dual-head setup
    -- in mind. It makes use of "XMonad.Util.PositionStore" as well as
    -- "XMonad.Hooks.PositionStoreHooks" . Since there is currently no way
    -- to move or resize windows with the keyboard alone in this layout,
    -- it is adviced to use it in combination with a decoration such as
    -- "XMonad.Layout.NoFrillsDecoration" (to move windows) and the
    -- layout modifier "XMonad.Layout.BorderResize" (to resize windows).
    --
    -----------------------------------------------------------------------------

    module XMonad.Layout.PositionStoreFloat
        ( -- * Usage
          -- $usage
          positionStoreFloat, PositionStoreFloat
        ) where

    import XMonad
    import XMonad.Util.PositionStore
    import qualified XMonad.StackSet as S
    import XMonad.Layout.WindowArranger
    import Control.Monad(when)
    import Data.Maybe(isJust)
    import Data.List(nub)

    -- $usage
    -- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:
    --
    -- > import XMonad.Layout.PositionStoreFloat
    -- > import XMonad.Layout.NoFrillsDecoration
    -- > import XMonad.Layout.BorderResize
    --
    -- Then edit your @layoutHook@ by adding the PositionStoreFloat layout.
    -- Below is a suggestion which uses the mentioned NoFrillsDecoration and
    -- BorderResize:
    --
    -- > myLayouts = floatingDeco $ borderResize $ positionStoreFloat ||| etc..
    -- >               where floatingDeco l = noFrillsDeco shrinkText defaultTheme l
    -- > main = xmonad defaultConfig { layoutHook = myLayouts }
    --
    -- See the documentation of "XMonad.Hooks.PositionStoreHooks" on how
    -- to add the support hooks.

    positionStoreFloat :: PositionStoreFloat a
    positionStoreFloat = PSF (Nothing, [])

    data PositionStoreFloat a = PSF (Maybe Rectangle, [a]) deriving (Show, Read)
    instance LayoutClass PositionStoreFloat Window where
        description _ = "PSF"
        doLayout (PSF (maybeChange, paintOrder)) sr (S.Stack w l r) = do
                posStore <- getPosStore
                let wrs = map (\w' -> (w', pSQ posStore w' sr)) (reverse l ++ r)
                let focused = case maybeChange of
                                Nothing -> (w, pSQ posStore w sr)
                                Just changedRect -> (w, changedRect)
                let wrs' = focused : wrs
                let paintOrder' = nub (w : paintOrder)
                when (isJust maybeChange) $ do
                    updatePositionStore focused sr
                return (reorder wrs' paintOrder', Just $ PSF (Nothing, paintOrder'))
            where
                pSQ posStore w' sr' = case (posStoreQuery posStore w' sr') of
                                        Just rect   -> rect
                                        Nothing     -> (Rectangle 50 50 200 200)  -- should usually not happen
        pureMessage (PSF (_, paintOrder)) m
            | Just (SetGeometry rect) <- fromMessage m =
                Just $ PSF (Just rect, paintOrder)
            | otherwise = Nothing

    updatePositionStore :: (Window, Rectangle) -> Rectangle -> X ()
    updatePositionStore (w, rect) sr = modifyPosStore (\ps ->
                                                posStoreInsert ps w rect sr)

    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 -> []