{-# LANGUAGE TypeSynonymInstances, MultiParamTypeClasses, PatternGuards #-}
----------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Layout.PositionStoreFloat
-- Description :  A floating layout; designed with a dual-head setup in mind.
-- 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 XMonad.Prelude (fromMaybe, isJust, nub, when)

-- $usage
-- You can use this module with the following in your @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 def l
-- > main = xmonad def { layoutHook = myLayouts }
--
-- See the documentation of "XMonad.Hooks.PositionStoreHooks" on how
-- to add the support hooks.

positionStoreFloat :: PositionStoreFloat a
positionStoreFloat :: forall a. PositionStoreFloat a
positionStoreFloat = forall a. (Maybe Rectangle, [a]) -> PositionStoreFloat a
PSF (forall a. Maybe a
Nothing, [])

newtype PositionStoreFloat a = PSF (Maybe Rectangle, [a]) deriving (Int -> PositionStoreFloat a -> ShowS
forall a. Show a => Int -> PositionStoreFloat a -> ShowS
forall a. Show a => [PositionStoreFloat a] -> ShowS
forall a. Show a => PositionStoreFloat a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PositionStoreFloat a] -> ShowS
$cshowList :: forall a. Show a => [PositionStoreFloat a] -> ShowS
show :: PositionStoreFloat a -> String
$cshow :: forall a. Show a => PositionStoreFloat a -> String
showsPrec :: Int -> PositionStoreFloat a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> PositionStoreFloat a -> ShowS
Show, ReadPrec [PositionStoreFloat a]
ReadPrec (PositionStoreFloat a)
ReadS [PositionStoreFloat a]
forall a. Read a => ReadPrec [PositionStoreFloat a]
forall a. Read a => ReadPrec (PositionStoreFloat a)
forall a. Read a => Int -> ReadS (PositionStoreFloat a)
forall a. Read a => ReadS [PositionStoreFloat a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [PositionStoreFloat a]
$creadListPrec :: forall a. Read a => ReadPrec [PositionStoreFloat a]
readPrec :: ReadPrec (PositionStoreFloat a)
$creadPrec :: forall a. Read a => ReadPrec (PositionStoreFloat a)
readList :: ReadS [PositionStoreFloat a]
$creadList :: forall a. Read a => ReadS [PositionStoreFloat a]
readsPrec :: Int -> ReadS (PositionStoreFloat a)
$creadsPrec :: forall a. Read a => Int -> ReadS (PositionStoreFloat a)
Read)
instance LayoutClass PositionStoreFloat Window where
    description :: PositionStoreFloat Window -> String
description PositionStoreFloat Window
_ = String
"PSF"
    doLayout :: PositionStoreFloat Window
-> Rectangle
-> Stack Window
-> X ([(Window, Rectangle)], Maybe (PositionStoreFloat Window))
doLayout (PSF (Maybe Rectangle
maybeChange, [Window]
paintOrder)) Rectangle
sr (S.Stack Window
w [Window]
l [Window]
r) = do
            PositionStore
posStore <- X PositionStore
getPosStore
            let wrs :: [(Window, Rectangle)]
wrs = forall a b. (a -> b) -> [a] -> [b]
map (\Window
w' -> (Window
w', PositionStore -> Window -> Rectangle -> Rectangle
pSQ PositionStore
posStore Window
w' Rectangle
sr)) (forall a. [a] -> [a]
reverse [Window]
l forall a. [a] -> [a] -> [a]
++ [Window]
r)
            let focused :: (Window, Rectangle)
focused = case Maybe Rectangle
maybeChange of
                            Maybe Rectangle
Nothing -> (Window
w, PositionStore -> Window -> Rectangle -> Rectangle
pSQ PositionStore
posStore Window
w Rectangle
sr)
                            Just Rectangle
changedRect -> (Window
w, Rectangle
changedRect)
            let wrs' :: [(Window, Rectangle)]
wrs' = (Window, Rectangle)
focused forall a. a -> [a] -> [a]
: [(Window, Rectangle)]
wrs
            let paintOrder' :: [Window]
paintOrder' = forall a. Eq a => [a] -> [a]
nub (Window
w forall a. a -> [a] -> [a]
: [Window]
paintOrder)
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isJust Maybe Rectangle
maybeChange) forall a b. (a -> b) -> a -> b
$
                (Window, Rectangle) -> Rectangle -> X ()
updatePositionStore (Window, Rectangle)
focused Rectangle
sr
            forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. Eq a => [(a, b)] -> [a] -> [(a, b)]
reorder [(Window, Rectangle)]
wrs' [Window]
paintOrder', forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. (Maybe Rectangle, [a]) -> PositionStoreFloat a
PSF (forall a. Maybe a
Nothing, [Window]
paintOrder'))
        where
            pSQ :: PositionStore -> Window -> Rectangle -> Rectangle
pSQ PositionStore
posStore Window
w' Rectangle
sr' = forall a. a -> Maybe a -> a
fromMaybe (Position -> Position -> Dimension -> Dimension -> Rectangle
Rectangle Position
50 Position
50 Dimension
200 Dimension
200)       -- should usually not happen
                                            (PositionStore -> Window -> Rectangle -> Maybe Rectangle
posStoreQuery PositionStore
posStore Window
w' Rectangle
sr')
    pureMessage :: PositionStoreFloat Window
-> SomeMessage -> Maybe (PositionStoreFloat Window)
pureMessage (PSF (Maybe Rectangle
_, [Window]
paintOrder)) SomeMessage
m
        | Just (SetGeometry Rectangle
rect) <- forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
m =
            forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. (Maybe Rectangle, [a]) -> PositionStoreFloat a
PSF (forall a. a -> Maybe a
Just Rectangle
rect, [Window]
paintOrder)
        | Bool
otherwise = forall a. Maybe a
Nothing

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

reorder :: (Eq a) => [(a, b)] -> [a] -> [(a, b)]
reorder :: forall a b. Eq a => [(a, b)] -> [a] -> [(a, b)]
reorder [(a, b)]
wrs [a]
order =
    let ordered :: [(a, b)]
ordered = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall {a} {b}. Eq a => [(a, b)] -> a -> [(a, b)]
pickElem [(a, b)]
wrs) [a]
order
        rest :: [(a, b)]
rest = forall a. (a -> Bool) -> [a] -> [a]
filter (\(a
w, b
_) -> a
w forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [a]
order) [(a, b)]
wrs
    in [(a, b)]
ordered forall a. [a] -> [a] -> [a]
++ [(a, b)]
rest
    where
        pickElem :: [(a, b)] -> a -> [(a, b)]
pickElem [(a, b)]
list a
e = case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup a
e [(a, b)]
list of
                                Just b
result -> [(a
e, b
result)]
                                Maybe b
Nothing -> []