-- |
-- Module      :  XMonad.Actions.ToggleFullFloat
-- Description :  Fullscreen (float) a window while remembering its original state.
-- Copyright   :  (c) 2022 Tomáš Janoušek <tomi@nomi.cz>
-- License     :  BSD3
-- Maintainer  :  Tomáš Janoušek <tomi@nomi.cz>
--
module XMonad.Actions.ToggleFullFloat (
    -- * Usage
    -- $usage
    toggleFullFloatEwmhFullscreen,
    toggleFullFloat,
    fullFloat,
    unFullFloat,
    gcToggleFullFloat,
    ) where

import qualified Data.Map.Strict as M

import XMonad
import XMonad.Prelude
import XMonad.Hooks.EwmhDesktops (setEwmhFullscreenHooks)
import XMonad.Hooks.ManageHelpers
import qualified XMonad.StackSet as W
import qualified XMonad.Util.ExtensibleState as XS

-- ---------------------------------------------------------------------
-- $usage
--
-- The main use-case is to make 'ewmhFullscreen' (re)store the size and
-- position of floating windows instead of just unconditionally sinking them
-- into the floating layer. To enable this, you'll need this in your
-- @xmonad.hs@:
--
-- > import XMonad
-- > import XMonad.Actions.ToggleFullFloat
-- > import XMonad.Hooks.EwmhDesktops
-- >
-- > main = xmonad $ … . toggleFullFloatEwmhFullscreen . ewmhFullscreen . ewmh . … $ def{…}
--
-- Additionally, this "smart" fullscreening can be bound to a key and invoked
-- manually whenever one needs a larger window temporarily:
--
-- >   , ((modMask .|. shiftMask, xK_t), withFocused toggleFullFloat)

newtype ToggleFullFloat = ToggleFullFloat{ ToggleFullFloat -> Map Window (Maybe RationalRect)
fromToggleFullFloat :: M.Map Window (Maybe W.RationalRect) }
    deriving (Int -> ToggleFullFloat -> ShowS
[ToggleFullFloat] -> ShowS
ToggleFullFloat -> String
(Int -> ToggleFullFloat -> ShowS)
-> (ToggleFullFloat -> String)
-> ([ToggleFullFloat] -> ShowS)
-> Show ToggleFullFloat
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ToggleFullFloat -> ShowS
showsPrec :: Int -> ToggleFullFloat -> ShowS
$cshow :: ToggleFullFloat -> String
show :: ToggleFullFloat -> String
$cshowList :: [ToggleFullFloat] -> ShowS
showList :: [ToggleFullFloat] -> ShowS
Show, ReadPrec [ToggleFullFloat]
ReadPrec ToggleFullFloat
Int -> ReadS ToggleFullFloat
ReadS [ToggleFullFloat]
(Int -> ReadS ToggleFullFloat)
-> ReadS [ToggleFullFloat]
-> ReadPrec ToggleFullFloat
-> ReadPrec [ToggleFullFloat]
-> Read ToggleFullFloat
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS ToggleFullFloat
readsPrec :: Int -> ReadS ToggleFullFloat
$creadList :: ReadS [ToggleFullFloat]
readList :: ReadS [ToggleFullFloat]
$creadPrec :: ReadPrec ToggleFullFloat
readPrec :: ReadPrec ToggleFullFloat
$creadListPrec :: ReadPrec [ToggleFullFloat]
readListPrec :: ReadPrec [ToggleFullFloat]
Read)

instance ExtensionClass ToggleFullFloat where
    extensionType :: ToggleFullFloat -> StateExtension
extensionType = ToggleFullFloat -> StateExtension
forall a. (Read a, Show a, ExtensionClass a) => a -> StateExtension
PersistentExtension
    initialValue :: ToggleFullFloat
initialValue = Map Window (Maybe RationalRect) -> ToggleFullFloat
ToggleFullFloat Map Window (Maybe RationalRect)
forall a. Monoid a => a
mempty

-- | Full-float a window, remembering its state (tiled/floating and
-- position/size).
fullFloat :: Window -> X ()
fullFloat :: Window -> X ()
fullFloat = (WindowSet -> WindowSet) -> X ()
windows ((WindowSet -> WindowSet) -> X ())
-> (Endo WindowSet -> WindowSet -> WindowSet)
-> Endo WindowSet
-> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Endo WindowSet -> WindowSet -> WindowSet
forall a. Endo a -> a -> a
appEndo (Endo WindowSet -> X ())
-> (Window -> X (Endo WindowSet)) -> Window -> X ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Query (Endo WindowSet) -> Window -> X (Endo WindowSet)
forall a. Query a -> Window -> X a
runQuery Query (Endo WindowSet)
doFullFloatSave

-- | Restore window to its remembered state.
unFullFloat :: Window -> X ()
unFullFloat :: Window -> X ()
unFullFloat = (WindowSet -> WindowSet) -> X ()
windows ((WindowSet -> WindowSet) -> X ())
-> (Endo WindowSet -> WindowSet -> WindowSet)
-> Endo WindowSet
-> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Endo WindowSet -> WindowSet -> WindowSet
forall a. Endo a -> a -> a
appEndo (Endo WindowSet -> X ())
-> (Window -> X (Endo WindowSet)) -> Window -> X ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Query (Endo WindowSet) -> Window -> X (Endo WindowSet)
forall a. Query a -> Window -> X a
runQuery Query (Endo WindowSet)
doFullFloatRestore

-- | Full-float a window, if it's not already full-floating. Otherwise,
-- restore its original state.
toggleFullFloat :: Window -> X ()
toggleFullFloat :: Window -> X ()
toggleFullFloat Window
w = X Bool -> X () -> X () -> X ()
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (Window -> X Bool
isFullFloat Window
w) (Window -> X ()
unFullFloat Window
w) (Window -> X ()
fullFloat Window
w)

isFullFloat :: Window -> X Bool
isFullFloat :: Window -> X Bool
isFullFloat Window
w = (XState -> Bool) -> X Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((XState -> Bool) -> X Bool) -> (XState -> Bool) -> X Bool
forall a b. (a -> b) -> a -> b
$ (RationalRect -> Maybe RationalRect
forall a. a -> Maybe a
Just RationalRect
fullRect Maybe RationalRect -> Maybe RationalRect -> Bool
forall a. Eq a => a -> a -> Bool
==) (Maybe RationalRect -> Bool)
-> (XState -> Maybe RationalRect) -> XState -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Window -> Map Window RationalRect -> Maybe RationalRect
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Window
w (Map Window RationalRect -> Maybe RationalRect)
-> (XState -> Map Window RationalRect)
-> XState
-> Maybe RationalRect
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WindowSet -> Map Window RationalRect
forall i l a sid sd. StackSet i l a sid sd -> Map a RationalRect
W.floating (WindowSet -> Map Window RationalRect)
-> (XState -> WindowSet) -> XState -> Map Window RationalRect
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XState -> WindowSet
windowset
  where
    fullRect :: RationalRect
fullRect = Rational -> Rational -> Rational -> Rational -> RationalRect
W.RationalRect Rational
0 Rational
0 Rational
1 Rational
1

doFullFloatSave :: ManageHook
doFullFloatSave :: Query (Endo WindowSet)
doFullFloatSave = do
    Window
w <- Query Window
forall r (m :: * -> *). MonadReader r m => m r
ask
    X () -> Query ()
forall a. X a -> Query a
liftX (X () -> Query ()) -> X () -> Query ()
forall a b. (a -> b) -> a -> b
$ do
        Maybe RationalRect
f <- (XState -> Maybe RationalRect) -> X (Maybe RationalRect)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((XState -> Maybe RationalRect) -> X (Maybe RationalRect))
-> (XState -> Maybe RationalRect) -> X (Maybe RationalRect)
forall a b. (a -> b) -> a -> b
$ Window -> Map Window RationalRect -> Maybe RationalRect
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Window
w (Map Window RationalRect -> Maybe RationalRect)
-> (XState -> Map Window RationalRect)
-> XState
-> Maybe RationalRect
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WindowSet -> Map Window RationalRect
forall i l a sid sd. StackSet i l a sid sd -> Map a RationalRect
W.floating (WindowSet -> Map Window RationalRect)
-> (XState -> WindowSet) -> XState -> Map Window RationalRect
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XState -> WindowSet
windowset
        -- @M.insertWith const@ = don't overwrite stored original state
        (ToggleFullFloat -> ToggleFullFloat) -> X ()
forall a (m :: * -> *).
(ExtensionClass a, XLike m) =>
(a -> a) -> m ()
XS.modify' ((ToggleFullFloat -> ToggleFullFloat) -> X ())
-> (ToggleFullFloat -> ToggleFullFloat) -> X ()
forall a b. (a -> b) -> a -> b
$ Map Window (Maybe RationalRect) -> ToggleFullFloat
ToggleFullFloat (Map Window (Maybe RationalRect) -> ToggleFullFloat)
-> (ToggleFullFloat -> Map Window (Maybe RationalRect))
-> ToggleFullFloat
-> ToggleFullFloat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe RationalRect -> Maybe RationalRect -> Maybe RationalRect)
-> Window
-> Maybe RationalRect
-> Map Window (Maybe RationalRect)
-> Map Window (Maybe RationalRect)
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith Maybe RationalRect -> Maybe RationalRect -> Maybe RationalRect
forall a b. a -> b -> a
const Window
w Maybe RationalRect
f (Map Window (Maybe RationalRect)
 -> Map Window (Maybe RationalRect))
-> (ToggleFullFloat -> Map Window (Maybe RationalRect))
-> ToggleFullFloat
-> Map Window (Maybe RationalRect)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ToggleFullFloat -> Map Window (Maybe RationalRect)
fromToggleFullFloat
    Query (Endo WindowSet)
doFullFloat

doFullFloatRestore :: ManageHook
doFullFloatRestore :: Query (Endo WindowSet)
doFullFloatRestore = do
    Window
w <- Query Window
forall r (m :: * -> *). MonadReader r m => m r
ask
    Maybe (Maybe RationalRect)
mf <- X (Maybe (Maybe RationalRect))
-> Query (Maybe (Maybe RationalRect))
forall a. X a -> Query a
liftX (X (Maybe (Maybe RationalRect))
 -> Query (Maybe (Maybe RationalRect)))
-> X (Maybe (Maybe RationalRect))
-> Query (Maybe (Maybe RationalRect))
forall a b. (a -> b) -> a -> b
$ do
        Maybe (Maybe RationalRect)
mf <- (ToggleFullFloat -> Maybe (Maybe RationalRect))
-> X (Maybe (Maybe RationalRect))
forall a (m :: * -> *) b.
(ExtensionClass a, XLike m) =>
(a -> b) -> m b
XS.gets ((ToggleFullFloat -> Maybe (Maybe RationalRect))
 -> X (Maybe (Maybe RationalRect)))
-> (ToggleFullFloat -> Maybe (Maybe RationalRect))
-> X (Maybe (Maybe RationalRect))
forall a b. (a -> b) -> a -> b
$ Window
-> Map Window (Maybe RationalRect) -> Maybe (Maybe RationalRect)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Window
w (Map Window (Maybe RationalRect) -> Maybe (Maybe RationalRect))
-> (ToggleFullFloat -> Map Window (Maybe RationalRect))
-> ToggleFullFloat
-> Maybe (Maybe RationalRect)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ToggleFullFloat -> Map Window (Maybe RationalRect)
fromToggleFullFloat
        (ToggleFullFloat -> ToggleFullFloat) -> X ()
forall a (m :: * -> *).
(ExtensionClass a, XLike m) =>
(a -> a) -> m ()
XS.modify' ((ToggleFullFloat -> ToggleFullFloat) -> X ())
-> (ToggleFullFloat -> ToggleFullFloat) -> X ()
forall a b. (a -> b) -> a -> b
$ Map Window (Maybe RationalRect) -> ToggleFullFloat
ToggleFullFloat (Map Window (Maybe RationalRect) -> ToggleFullFloat)
-> (ToggleFullFloat -> Map Window (Maybe RationalRect))
-> ToggleFullFloat
-> ToggleFullFloat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Window
-> Map Window (Maybe RationalRect)
-> Map Window (Maybe RationalRect)
forall k a. Ord k => k -> Map k a -> Map k a
M.delete Window
w (Map Window (Maybe RationalRect)
 -> Map Window (Maybe RationalRect))
-> (ToggleFullFloat -> Map Window (Maybe RationalRect))
-> ToggleFullFloat
-> Map Window (Maybe RationalRect)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ToggleFullFloat -> Map Window (Maybe RationalRect)
fromToggleFullFloat
        Maybe (Maybe RationalRect) -> X (Maybe (Maybe RationalRect))
forall a. a -> X a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Maybe RationalRect)
mf
    (WindowSet -> WindowSet) -> Query (Endo WindowSet)
forall s. (s -> s) -> Query (Endo s)
doF ((WindowSet -> WindowSet) -> Query (Endo WindowSet))
-> (WindowSet -> WindowSet) -> Query (Endo WindowSet)
forall a b. (a -> b) -> a -> b
$ case Maybe (Maybe RationalRect)
mf of
        Just (Just RationalRect
f) -> Window -> RationalRect -> WindowSet -> WindowSet
forall a i l s sd.
Ord a =>
a -> RationalRect -> StackSet i l a s sd -> StackSet i l a s sd
W.float Window
w RationalRect
f  -- was floating before
        Just Maybe RationalRect
Nothing -> Window -> WindowSet -> WindowSet
forall a i l s sd.
Ord a =>
a -> StackSet i l a s sd -> StackSet i l a s sd
W.sink Window
w      -- was tiled before
        Maybe (Maybe RationalRect)
Nothing -> Window -> WindowSet -> WindowSet
forall a i l s sd.
Ord a =>
a -> StackSet i l a s sd -> StackSet i l a s sd
W.sink Window
w           -- fallback when not found in ToggleFullFloat

-- | Install ToggleFullFloat garbage collection hooks.
--
-- Note: This is included in 'toggleFullFloatEwmhFullscreen', only needed if
-- using the 'toggleFullFloat' separately from the EWMH hook.
gcToggleFullFloat :: XConfig a -> XConfig a
gcToggleFullFloat :: forall (a :: * -> *). XConfig a -> XConfig a
gcToggleFullFloat XConfig a
c = XConfig a
c { startupHook     = startupHook c <> gcToggleFullFloatStartupHook
                        , handleEventHook = handleEventHook c <> gcToggleFullFloatEventHook }

-- | ToggleFullFloat garbage collection: drop windows when they're destroyed.
gcToggleFullFloatEventHook :: Event -> X All
gcToggleFullFloatEventHook :: Event -> X All
gcToggleFullFloatEventHook DestroyWindowEvent{ev_window :: Event -> Window
ev_window = Window
w} = do
    (ToggleFullFloat -> ToggleFullFloat) -> X ()
forall a (m :: * -> *).
(ExtensionClass a, XLike m) =>
(a -> a) -> m ()
XS.modify' ((ToggleFullFloat -> ToggleFullFloat) -> X ())
-> (ToggleFullFloat -> ToggleFullFloat) -> X ()
forall a b. (a -> b) -> a -> b
$ Map Window (Maybe RationalRect) -> ToggleFullFloat
ToggleFullFloat (Map Window (Maybe RationalRect) -> ToggleFullFloat)
-> (ToggleFullFloat -> Map Window (Maybe RationalRect))
-> ToggleFullFloat
-> ToggleFullFloat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Window
-> Map Window (Maybe RationalRect)
-> Map Window (Maybe RationalRect)
forall k a. Ord k => k -> Map k a -> Map k a
M.delete Window
w (Map Window (Maybe RationalRect)
 -> Map Window (Maybe RationalRect))
-> (ToggleFullFloat -> Map Window (Maybe RationalRect))
-> ToggleFullFloat
-> Map Window (Maybe RationalRect)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ToggleFullFloat -> Map Window (Maybe RationalRect)
fromToggleFullFloat
    X All
forall a. Monoid a => a
mempty
gcToggleFullFloatEventHook Event
_ = X All
forall a. Monoid a => a
mempty

-- | ToggleFullFloat garbage collection: restrict to existing windows at
-- startup.
gcToggleFullFloatStartupHook :: X ()
gcToggleFullFloatStartupHook :: X ()
gcToggleFullFloatStartupHook = (WindowSet -> X ()) -> X ()
forall a. (WindowSet -> X a) -> X a
withWindowSet ((WindowSet -> X ()) -> X ()) -> (WindowSet -> X ()) -> X ()
forall a b. (a -> b) -> a -> b
$ \WindowSet
ws ->
    (ToggleFullFloat -> ToggleFullFloat) -> X ()
forall a (m :: * -> *).
(ExtensionClass a, XLike m) =>
(a -> a) -> m ()
XS.modify' ((ToggleFullFloat -> ToggleFullFloat) -> X ())
-> (ToggleFullFloat -> ToggleFullFloat) -> X ()
forall a b. (a -> b) -> a -> b
$ Map Window (Maybe RationalRect) -> ToggleFullFloat
ToggleFullFloat (Map Window (Maybe RationalRect) -> ToggleFullFloat)
-> (ToggleFullFloat -> Map Window (Maybe RationalRect))
-> ToggleFullFloat
-> ToggleFullFloat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Window -> Maybe RationalRect -> Bool)
-> Map Window (Maybe RationalRect)
-> Map Window (Maybe RationalRect)
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
M.filterWithKey (\Window
w Maybe RationalRect
_ -> Window
w Window -> WindowSet -> Bool
forall a i l s sd. Eq a => a -> StackSet i l a s sd -> Bool
`W.member` WindowSet
ws) (Map Window (Maybe RationalRect)
 -> Map Window (Maybe RationalRect))
-> (ToggleFullFloat -> Map Window (Maybe RationalRect))
-> ToggleFullFloat
-> Map Window (Maybe RationalRect)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ToggleFullFloat -> Map Window (Maybe RationalRect)
fromToggleFullFloat

-- | Hook this module into 'XMonad.Hooks.EwmhDesktops.ewmhFullscreen'. This
-- makes windows restore their original state (size and position if floating)
-- instead of unconditionally sinking into the tiling layer.
--
-- ('gcToggleFullFloat' is included here.)
toggleFullFloatEwmhFullscreen :: XConfig a -> XConfig a
toggleFullFloatEwmhFullscreen :: forall (a :: * -> *). XConfig a -> XConfig a
toggleFullFloatEwmhFullscreen =
    Query (Endo WindowSet)
-> Query (Endo WindowSet) -> XConfig a -> XConfig a
forall (l :: * -> *).
Query (Endo WindowSet)
-> Query (Endo WindowSet) -> XConfig l -> XConfig l
setEwmhFullscreenHooks Query (Endo WindowSet)
doFullFloatSave Query (Endo WindowSet)
doFullFloatRestore (XConfig a -> XConfig a)
-> (XConfig a -> XConfig a) -> XConfig a -> XConfig a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    XConfig a -> XConfig a
forall (a :: * -> *). XConfig a -> XConfig a
gcToggleFullFloat