-- |
-- 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ToggleFullFloat] -> ShowS
$cshowList :: [ToggleFullFloat] -> ShowS
show :: ToggleFullFloat -> String
$cshow :: ToggleFullFloat -> String
showsPrec :: Int -> ToggleFullFloat -> ShowS
$cshowsPrec :: Int -> ToggleFullFloat -> ShowS
Show, ReadPrec [ToggleFullFloat]
ReadPrec ToggleFullFloat
Int -> ReadS ToggleFullFloat
ReadS [ToggleFullFloat]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [ToggleFullFloat]
$creadListPrec :: ReadPrec [ToggleFullFloat]
readPrec :: ReadPrec ToggleFullFloat
$creadPrec :: ReadPrec ToggleFullFloat
readList :: ReadS [ToggleFullFloat]
$creadList :: ReadS [ToggleFullFloat]
readsPrec :: Int -> ReadS ToggleFullFloat
$creadsPrec :: Int -> ReadS ToggleFullFloat
Read)

instance ExtensionClass ToggleFullFloat where
    extensionType :: ToggleFullFloat -> StateExtension
extensionType = forall a. (Read a, Show a, ExtensionClass a) => a -> StateExtension
PersistentExtension
    initialValue :: ToggleFullFloat
initialValue = Map Window (Maybe RationalRect) -> ToggleFullFloat
ToggleFullFloat 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Endo a -> a -> a
appEndo forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall a. Query a -> Window -> X a
runQuery ManageHook
doFullFloatSave

-- | Restore window to its remembered state.
unFullFloat :: Window -> X ()
unFullFloat :: Window -> X ()
unFullFloat = (WindowSet -> WindowSet) -> X ()
windows forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Endo a -> a -> a
appEndo forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall a. Query a -> Window -> X a
runQuery ManageHook
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 = 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 = forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a b. (a -> b) -> a -> b
$ (forall a. a -> Maybe a
Just RationalRect
fullRect forall a. Eq a => a -> a -> Bool
==) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Window
w forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall i l a sid sd. StackSet i l a sid sd -> Map a RationalRect
W.floating 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 :: ManageHook
doFullFloatSave = do
    Window
w <- forall r (m :: * -> *). MonadReader r m => m r
ask
    forall a. X a -> Query a
liftX forall a b. (a -> b) -> a -> b
$ do
        Maybe RationalRect
f <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Window
w forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall i l a sid sd. StackSet i l a sid sd -> Map a RationalRect
W.floating forall b c a. (b -> c) -> (a -> b) -> a -> c
. XState -> WindowSet
windowset
        -- @M.insertWith const@ = don't overwrite stored original state
        forall a (m :: * -> *).
(ExtensionClass a, XLike m) =>
(a -> a) -> m ()
XS.modify' forall a b. (a -> b) -> a -> b
$ Map Window (Maybe RationalRect) -> ToggleFullFloat
ToggleFullFloat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith forall a b. a -> b -> a
const Window
w Maybe RationalRect
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. ToggleFullFloat -> Map Window (Maybe RationalRect)
fromToggleFullFloat
    ManageHook
doFullFloat

doFullFloatRestore :: ManageHook
doFullFloatRestore :: ManageHook
doFullFloatRestore = do
    Window
w <- forall r (m :: * -> *). MonadReader r m => m r
ask
    Maybe (Maybe RationalRect)
mf <- forall a. X a -> Query a
liftX forall a b. (a -> b) -> a -> b
$ do
        Maybe (Maybe RationalRect)
mf <- forall a (m :: * -> *) b.
(ExtensionClass a, XLike m) =>
(a -> b) -> m b
XS.gets forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Window
w forall b c a. (b -> c) -> (a -> b) -> a -> c
. ToggleFullFloat -> Map Window (Maybe RationalRect)
fromToggleFullFloat
        forall a (m :: * -> *).
(ExtensionClass a, XLike m) =>
(a -> a) -> m ()
XS.modify' forall a b. (a -> b) -> a -> b
$ Map Window (Maybe RationalRect) -> ToggleFullFloat
ToggleFullFloat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => k -> Map k a -> Map k a
M.delete Window
w forall b c a. (b -> c) -> (a -> b) -> a -> c
. ToggleFullFloat -> Map Window (Maybe RationalRect)
fromToggleFullFloat
        forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Maybe RationalRect)
mf
    forall s. (s -> s) -> Query (Endo s)
doF forall a b. (a -> b) -> a -> b
$ case Maybe (Maybe RationalRect)
mf of
        Just (Just RationalRect
f) -> 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 -> 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 -> 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 :: X ()
startupHook     = forall (l :: * -> *). XConfig l -> X ()
startupHook XConfig a
c forall a. Semigroup a => a -> a -> a
<> X ()
gcToggleFullFloatStartupHook
                        , handleEventHook :: Event -> X All
handleEventHook = forall (l :: * -> *). XConfig l -> Event -> X All
handleEventHook XConfig a
c forall a. Semigroup a => a -> a -> a
<> Event -> X All
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
    forall a (m :: * -> *).
(ExtensionClass a, XLike m) =>
(a -> a) -> m ()
XS.modify' forall a b. (a -> b) -> a -> b
$ Map Window (Maybe RationalRect) -> ToggleFullFloat
ToggleFullFloat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => k -> Map k a -> Map k a
M.delete Window
w forall b c a. (b -> c) -> (a -> b) -> a -> c
. ToggleFullFloat -> Map Window (Maybe RationalRect)
fromToggleFullFloat
    forall a. Monoid a => a
mempty
gcToggleFullFloatEventHook Event
_ = forall a. Monoid a => a
mempty

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