{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Layout.Drawer
-- Description :  A layout modifier to put windows in a "drawer".
-- Copyright   :  (c) 2009 Max Rabkin
-- License     :  BSD-style (see xmonad/LICENSE)
--
-- Maintainer  :  max.rabkin@gmail.com
-- Stability   :  unstable
-- Portability :  unportable
--
-- A layout modifier that puts some windows in a "drawer" which retracts and
-- expands depending on whether any window in it has focus.
--
-- Useful for music players, tool palettes, etc.
--
-----------------------------------------------------------------------------

module XMonad.Layout.Drawer
    ( -- * Usage
      -- $usage

      -- * Drawers
      simpleDrawer
    , drawer

      -- * Placing drawers
      -- The drawer can be placed on any side of the screen with these functions
    , onLeft, onTop, onRight, onBottom

    , module XMonad.Util.WindowProperties

    , Drawer, Reflected
    ) where

import XMonad
import XMonad.Layout.LayoutModifier
import XMonad.Util.WindowProperties
import XMonad.StackSet as S
import XMonad.Layout.Reflect

-- $usage
-- To use this module, add the following import to @~\/.xmonad\/xmonad.hs@:
--
-- > import XMonad.Layout.Drawer
--
-- > myLayout = drawer `onTop` (Tall 1 0.03 0.5) ||| Full ||| RandomOtherLayout...
-- >     where
-- >         drawer = simpleDrawer 0.01 0.3 (ClassName "Rhythmbox" `Or` ClassName "Xchat")
-- >
-- > main = xmonad def { layoutHook = myLayout }
--
-- This will place the Rhythmbox and Xchat windows in at the top of the screen
-- only when using the 'Tall' layout.  See "XMonad.Util.WindowProperties" for
-- more information on selecting windows.

data Drawer l a = Drawer Rational Rational Property (l a)
    deriving (ReadPrec [Drawer l a]
ReadPrec (Drawer l a)
Int -> ReadS (Drawer l a)
ReadS [Drawer l a]
(Int -> ReadS (Drawer l a))
-> ReadS [Drawer l a]
-> ReadPrec (Drawer l a)
-> ReadPrec [Drawer l a]
-> Read (Drawer l a)
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
forall (l :: * -> *) a. Read (l a) => ReadPrec [Drawer l a]
forall (l :: * -> *) a. Read (l a) => ReadPrec (Drawer l a)
forall (l :: * -> *) a. Read (l a) => Int -> ReadS (Drawer l a)
forall (l :: * -> *) a. Read (l a) => ReadS [Drawer l a]
readListPrec :: ReadPrec [Drawer l a]
$creadListPrec :: forall (l :: * -> *) a. Read (l a) => ReadPrec [Drawer l a]
readPrec :: ReadPrec (Drawer l a)
$creadPrec :: forall (l :: * -> *) a. Read (l a) => ReadPrec (Drawer l a)
readList :: ReadS [Drawer l a]
$creadList :: forall (l :: * -> *) a. Read (l a) => ReadS [Drawer l a]
readsPrec :: Int -> ReadS (Drawer l a)
$creadsPrec :: forall (l :: * -> *) a. Read (l a) => Int -> ReadS (Drawer l a)
Read, Int -> Drawer l a -> ShowS
[Drawer l a] -> ShowS
Drawer l a -> String
(Int -> Drawer l a -> ShowS)
-> (Drawer l a -> String)
-> ([Drawer l a] -> ShowS)
-> Show (Drawer l a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (l :: * -> *) a. Show (l a) => Int -> Drawer l a -> ShowS
forall (l :: * -> *) a. Show (l a) => [Drawer l a] -> ShowS
forall (l :: * -> *) a. Show (l a) => Drawer l a -> String
showList :: [Drawer l a] -> ShowS
$cshowList :: forall (l :: * -> *) a. Show (l a) => [Drawer l a] -> ShowS
show :: Drawer l a -> String
$cshow :: forall (l :: * -> *) a. Show (l a) => Drawer l a -> String
showsPrec :: Int -> Drawer l a -> ShowS
$cshowsPrec :: forall (l :: * -> *) a. Show (l a) => Int -> Drawer l a -> ShowS
Show)

-- | filter : filterM :: partition : partitionM
partitionM :: Monad m => (a -> m Bool) -> [a] -> m ([a], [a])
partitionM :: forall (m :: * -> *) a.
Monad m =>
(a -> m Bool) -> [a] -> m ([a], [a])
partitionM a -> m Bool
_ [] = ([a], [a]) -> m ([a], [a])
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [])
partitionM a -> m Bool
f (a
x:[a]
xs) = do
    Bool
b <- a -> m Bool
f a
x
    ([a]
ys, [a]
zs) <- (a -> m Bool) -> [a] -> m ([a], [a])
forall (m :: * -> *) a.
Monad m =>
(a -> m Bool) -> [a] -> m ([a], [a])
partitionM a -> m Bool
f [a]
xs
    ([a], [a]) -> m ([a], [a])
forall (m :: * -> *) a. Monad m => a -> m a
return (([a], [a]) -> m ([a], [a])) -> ([a], [a]) -> m ([a], [a])
forall a b. (a -> b) -> a -> b
$ if Bool
b
                then (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
ys, [a]
zs)
                else ([a]
ys, a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
zs)

instance (LayoutClass l Window, Read (l Window)) => LayoutModifier (Drawer l) Window where
    modifyLayout :: forall (l :: * -> *).
LayoutClass l Window =>
Drawer l Window
-> Workspace String (l Window) Window
-> Rectangle
-> X ([(Window, Rectangle)], Maybe (l Window))
modifyLayout (Drawer Rational
rs Rational
rb Property
p l Window
l) Workspace String (l Window) Window
ws Rectangle
rect =
        case Workspace String (l Window) Window -> Maybe (Stack Window)
forall i l a. Workspace i l a -> Maybe (Stack a)
stack Workspace String (l Window) Window
ws of
            Maybe (Stack Window)
Nothing -> Workspace String (l Window) Window
-> Rectangle -> X ([(Window, Rectangle)], Maybe (l Window))
forall (layout :: * -> *) a.
LayoutClass layout a =>
Workspace String (layout a) a
-> Rectangle -> X ([(a, Rectangle)], Maybe (layout a))
runLayout Workspace String (l Window) Window
ws Rectangle
rect
            Just stk :: Stack Window
stk@Stack{ up :: forall a. Stack a -> [a]
up=[Window]
up_, down :: forall a. Stack a -> [a]
down=[Window]
down_, focus :: forall a. Stack a -> a
S.focus=Window
w } -> do
                    ([Window]
upD, [Window]
upM) <- (Window -> X Bool) -> [Window] -> X ([Window], [Window])
forall (m :: * -> *) a.
Monad m =>
(a -> m Bool) -> [a] -> m ([a], [a])
partitionM (Property -> Window -> X Bool
hasProperty Property
p) [Window]
up_
                    ([Window]
downD, [Window]
downM) <- (Window -> X Bool) -> [Window] -> X ([Window], [Window])
forall (m :: * -> *) a.
Monad m =>
(a -> m Bool) -> [a] -> m ([a], [a])
partitionM (Property -> Window -> X Bool
hasProperty Property
p) [Window]
down_
                    Bool
b <- Property -> Window -> X Bool
hasProperty Property
p Window
w
                    Maybe Window
focusedWindow <- (XState -> Maybe Window) -> X (Maybe Window)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((Stack Window -> Window) -> Maybe (Stack Window) -> Maybe Window
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Stack Window -> Window
forall a. Stack a -> a
S.focus (Maybe (Stack Window) -> Maybe Window)
-> (XState -> Maybe (Stack Window)) -> XState -> Maybe Window
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Workspace String (Layout Window) Window -> Maybe (Stack Window)
forall i l a. Workspace i l a -> Maybe (Stack a)
stack (Workspace String (Layout Window) Window -> Maybe (Stack Window))
-> (XState -> Workspace String (Layout Window) Window)
-> XState
-> Maybe (Stack Window)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Screen String (Layout Window) Window ScreenId ScreenDetail
-> Workspace String (Layout Window) Window
forall i l a sid sd. Screen i l a sid sd -> Workspace i l a
workspace (Screen String (Layout Window) Window ScreenId ScreenDetail
 -> Workspace String (Layout Window) Window)
-> (XState
    -> Screen String (Layout Window) Window ScreenId ScreenDetail)
-> XState
-> Workspace String (Layout Window) Window
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StackSet String (Layout Window) Window ScreenId ScreenDetail
-> Screen String (Layout Window) Window ScreenId ScreenDetail
forall i l a sid sd. StackSet i l a sid sd -> Screen i l a sid sd
current (StackSet String (Layout Window) Window ScreenId ScreenDetail
 -> Screen String (Layout Window) Window ScreenId ScreenDetail)
-> (XState
    -> StackSet String (Layout Window) Window ScreenId ScreenDetail)
-> XState
-> Screen String (Layout Window) Window ScreenId ScreenDetail
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XState
-> StackSet String (Layout Window) Window ScreenId ScreenDetail
windowset)

                    let rectD :: Rectangle
rectD = if Bool
b Bool -> Bool -> Bool
&& Window -> Maybe Window
forall a. a -> Maybe a
Just Window
w Maybe Window -> Maybe Window -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Window
focusedWindow then Rectangle
rectB else Rectangle
rectS

                    let (Maybe (Stack Window)
stackD, Maybe (Stack Window)
stackM) = if Bool
b
                                            then ( Stack Window -> Maybe (Stack Window)
forall a. a -> Maybe a
Just (Stack Window -> Maybe (Stack Window))
-> Stack Window -> Maybe (Stack Window)
forall a b. (a -> b) -> a -> b
$ Stack Window
stk { up :: [Window]
up=[Window]
upD, down :: [Window]
down=[Window]
downD }
                                                 , [Window] -> [Window] -> Maybe (Stack Window)
forall {a}. [a] -> [a] -> Maybe (Stack a)
mkStack [Window]
upM [Window]
downM )
                                            else ( [Window] -> [Window] -> Maybe (Stack Window)
forall {a}. [a] -> [a] -> Maybe (Stack a)
mkStack [Window]
upD [Window]
downD
                                                 , Stack Window -> Maybe (Stack Window)
forall a. a -> Maybe a
Just (Stack Window -> Maybe (Stack Window))
-> Stack Window -> Maybe (Stack Window)
forall a b. (a -> b) -> a -> b
$ Stack Window
stk { up :: [Window]
up=[Window]
upM, down :: [Window]
down=[Window]
downM } )

                    ([(Window, Rectangle)]
winsD, Maybe (l Window)
_) <- Workspace String (l Window) Window
-> Rectangle -> X ([(Window, Rectangle)], Maybe (l Window))
forall (layout :: * -> *) a.
LayoutClass layout a =>
Workspace String (layout a) a
-> Rectangle -> X ([(a, Rectangle)], Maybe (layout a))
runLayout (Workspace String (l Window) Window
ws { layout :: l Window
layout=l Window
l, stack :: Maybe (Stack Window)
stack=Maybe (Stack Window)
stackD }) Rectangle
rectD
                    ([(Window, Rectangle)]
winsM, Maybe (l Window)
u') <- Workspace String (l Window) Window
-> Rectangle -> X ([(Window, Rectangle)], Maybe (l Window))
forall (layout :: * -> *) a.
LayoutClass layout a =>
Workspace String (layout a) a
-> Rectangle -> X ([(a, Rectangle)], Maybe (layout a))
runLayout (Workspace String (l Window) Window
ws { stack :: Maybe (Stack Window)
stack=Maybe (Stack Window)
stackM }) Rectangle
rectM
                    ([(Window, Rectangle)], Maybe (l Window))
-> X ([(Window, Rectangle)], Maybe (l Window))
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Window, Rectangle)]
winsD [(Window, Rectangle)]
-> [(Window, Rectangle)] -> [(Window, Rectangle)]
forall a. [a] -> [a] -> [a]
++ [(Window, Rectangle)]
winsM, Maybe (l Window)
u')
      where
        mkStack :: [a] -> [a] -> Maybe (Stack a)
mkStack [] [] = Maybe (Stack a)
forall a. Maybe a
Nothing
        mkStack [a]
xs (a
y:[a]
ys) = Stack a -> Maybe (Stack a)
forall a. a -> Maybe a
Just (Stack :: forall a. a -> [a] -> [a] -> Stack a
Stack { up :: [a]
up=[a]
xs, focus :: a
S.focus=a
y, down :: [a]
down=[a]
ys })
        mkStack (a
x:[a]
xs) [a]
ys = Stack a -> Maybe (Stack a)
forall a. a -> Maybe a
Just (Stack :: forall a. a -> [a] -> [a] -> Stack a
Stack { up :: [a]
up=[a]
xs, focus :: a
S.focus=a
x, down :: [a]
down=[a]
ys })

        rectB :: Rectangle
rectB = Rectangle
rect { rect_width :: Dimension
rect_width=Rational -> Dimension
forall a b. (RealFrac a, Integral b) => a -> b
round (Rational -> Dimension) -> Rational -> Dimension
forall a b. (a -> b) -> a -> b
$ Dimension -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Rectangle -> Dimension
rect_width Rectangle
rect) Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Rational
rb }
        rectS :: Rectangle
rectS = Rectangle
rectB { rect_x :: Position
rect_x=Rectangle -> Position
rect_x Rectangle
rectB Position -> Position -> Position
forall a. Num a => a -> a -> a
- Rational -> Position
forall a b. (RealFrac a, Integral b) => a -> b
round ((Rational
rb Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
- Rational
rs) Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Dimension -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Rectangle -> Dimension
rect_width Rectangle
rect)) }
        rectM :: Rectangle
rectM = Rectangle
rect { rect_x :: Position
rect_x=Rectangle -> Position
rect_x Rectangle
rect Position -> Position -> Position
forall a. Num a => a -> a -> a
+ Rational -> Position
forall a b. (RealFrac a, Integral b) => a -> b
round (Dimension -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Rectangle -> Dimension
rect_width Rectangle
rect) Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Rational
rs)
                     , rect_width :: Dimension
rect_width=Rectangle -> Dimension
rect_width Rectangle
rect Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
- Rational -> Dimension
forall a b. (RealFrac a, Integral b) => a -> b
round (Dimension -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Rectangle -> Dimension
rect_width Rectangle
rect) Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Rational
rs) }

type Reflected l = ModifiedLayout Reflect l

-- | Construct a drawer with a simple layout of the windows inside
simpleDrawer :: Rational -- ^ The portion of the screen taken up by the drawer when closed
              -> Rational   -- ^ The portion of the screen taken up by the drawer when open
              -> Property   -- ^ Which windows to put in the drawer
              -> Drawer Tall a
simpleDrawer :: forall a. Rational -> Rational -> Property -> Drawer Tall a
simpleDrawer Rational
rs Rational
rb Property
p = Rational -> Rational -> Property -> Tall a -> Drawer Tall a
forall (l :: * -> *) a.
Rational -> Rational -> Property -> l a -> Drawer l a
Drawer Rational
rs Rational
rb Property
p Tall a
forall {a}. Tall a
vertical
    where
        vertical :: Tall a
vertical = Int -> Rational -> Rational -> Tall a
forall a. Int -> Rational -> Rational -> Tall a
Tall Int
0 Rational
0 Rational
0

-- Export a synonym for the constructor as a Haddock workaround
-- | Construct a drawer with an arbitrary layout for windows inside
drawer ::    Rational   -- ^ The portion of the screen taken up by the drawer when closed
          -> Rational   -- ^ The portion of the screen taken up by the drawer when open
          -> Property   -- ^ Which windows to put in the drawer
          -> l a        -- ^ The layout of windows in the drawer
          -> Drawer l a
drawer :: forall (l :: * -> *) a.
Rational -> Rational -> Property -> l a -> Drawer l a
drawer = Rational -> Rational -> Property -> l a -> Drawer l a
forall (l :: * -> *) a.
Rational -> Rational -> Property -> l a -> Drawer l a
Drawer

onLeft :: Drawer l a -> l' a -> ModifiedLayout (Drawer l) l' a
onLeft :: forall (l :: * -> *) a (l' :: * -> *).
Drawer l a -> l' a -> ModifiedLayout (Drawer l) l' a
onLeft = Drawer l a -> l' a -> ModifiedLayout (Drawer l) l' a
forall (m :: * -> *) (l :: * -> *) a.
m a -> l a -> ModifiedLayout m l a
ModifiedLayout

onRight :: Drawer l a -> l' a -> Reflected (ModifiedLayout (Drawer l) (Reflected l')) a
onRight :: forall (l :: * -> *) a (l' :: * -> *).
Drawer l a
-> l' a -> Reflected (ModifiedLayout (Drawer l) (Reflected l')) a
onRight Drawer l a
d = ModifiedLayout (Drawer l) (ModifiedLayout Reflect l') a
-> ModifiedLayout
     Reflect (ModifiedLayout (Drawer l) (ModifiedLayout Reflect l')) a
forall (l :: * -> *) a. l a -> ModifiedLayout Reflect l a
reflectHoriz (ModifiedLayout (Drawer l) (ModifiedLayout Reflect l') a
 -> ModifiedLayout
      Reflect (ModifiedLayout (Drawer l) (ModifiedLayout Reflect l')) a)
-> (l' a
    -> ModifiedLayout (Drawer l) (ModifiedLayout Reflect l') a)
-> l' a
-> ModifiedLayout
     Reflect (ModifiedLayout (Drawer l) (ModifiedLayout Reflect l')) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Drawer l a
-> ModifiedLayout Reflect l' a
-> ModifiedLayout (Drawer l) (ModifiedLayout Reflect l') a
forall (l :: * -> *) a (l' :: * -> *).
Drawer l a -> l' a -> ModifiedLayout (Drawer l) l' a
onLeft Drawer l a
d (ModifiedLayout Reflect l' a
 -> ModifiedLayout (Drawer l) (ModifiedLayout Reflect l') a)
-> (l' a -> ModifiedLayout Reflect l' a)
-> l' a
-> ModifiedLayout (Drawer l) (ModifiedLayout Reflect l') a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. l' a -> ModifiedLayout Reflect l' a
forall (l :: * -> *) a. l a -> ModifiedLayout Reflect l a
reflectHoriz

onTop :: Drawer l a -> l' a -> Mirror (ModifiedLayout (Drawer l) (Mirror l')) a
onTop :: forall (l :: * -> *) a (l' :: * -> *).
Drawer l a
-> l' a -> Mirror (ModifiedLayout (Drawer l) (Mirror l')) a
onTop Drawer l a
d = ModifiedLayout (Drawer l) (Mirror l') a
-> Mirror (ModifiedLayout (Drawer l) (Mirror l')) a
forall (l :: * -> *) a. l a -> Mirror l a
Mirror (ModifiedLayout (Drawer l) (Mirror l') a
 -> Mirror (ModifiedLayout (Drawer l) (Mirror l')) a)
-> (l' a -> ModifiedLayout (Drawer l) (Mirror l') a)
-> l' a
-> Mirror (ModifiedLayout (Drawer l) (Mirror l')) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Drawer l a
-> Mirror l' a -> ModifiedLayout (Drawer l) (Mirror l') a
forall (l :: * -> *) a (l' :: * -> *).
Drawer l a -> l' a -> ModifiedLayout (Drawer l) l' a
onLeft Drawer l a
d (Mirror l' a -> ModifiedLayout (Drawer l) (Mirror l') a)
-> (l' a -> Mirror l' a)
-> l' a
-> ModifiedLayout (Drawer l) (Mirror l') a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. l' a -> Mirror l' a
forall (l :: * -> *) a. l a -> Mirror l a
Mirror

onBottom :: Drawer l a -> l' a -> Reflected (Mirror (ModifiedLayout (Drawer l) (Mirror (Reflected l')))) a
onBottom :: forall (l :: * -> *) a (l' :: * -> *).
Drawer l a
-> l' a
-> Reflected
     (Mirror (ModifiedLayout (Drawer l) (Mirror (Reflected l')))) a
onBottom Drawer l a
d = Mirror
  (ModifiedLayout (Drawer l) (Mirror (ModifiedLayout Reflect l'))) a
-> ModifiedLayout
     Reflect
     (Mirror
        (ModifiedLayout (Drawer l) (Mirror (ModifiedLayout Reflect l'))))
     a
forall (l :: * -> *) a. l a -> ModifiedLayout Reflect l a
reflectVert (Mirror
   (ModifiedLayout (Drawer l) (Mirror (ModifiedLayout Reflect l'))) a
 -> ModifiedLayout
      Reflect
      (Mirror
         (ModifiedLayout (Drawer l) (Mirror (ModifiedLayout Reflect l'))))
      a)
-> (l' a
    -> Mirror
         (ModifiedLayout (Drawer l) (Mirror (ModifiedLayout Reflect l'))) a)
-> l' a
-> ModifiedLayout
     Reflect
     (Mirror
        (ModifiedLayout (Drawer l) (Mirror (ModifiedLayout Reflect l'))))
     a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Drawer l a
-> ModifiedLayout Reflect l' a
-> Mirror
     (ModifiedLayout (Drawer l) (Mirror (ModifiedLayout Reflect l'))) a
forall (l :: * -> *) a (l' :: * -> *).
Drawer l a
-> l' a -> Mirror (ModifiedLayout (Drawer l) (Mirror l')) a
onTop Drawer l a
d (ModifiedLayout Reflect l' a
 -> Mirror
      (ModifiedLayout (Drawer l) (Mirror (ModifiedLayout Reflect l'))) a)
-> (l' a -> ModifiedLayout Reflect l' a)
-> l' a
-> Mirror
     (ModifiedLayout (Drawer l) (Mirror (ModifiedLayout Reflect l'))) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. l' a -> ModifiedLayout Reflect l' a
forall (l :: * -> *) a. l a -> ModifiedLayout Reflect l a
reflectVert