path: root/src/Rahm/Desktop/Keys/Wml.hs

-- Wml: Window Management Language.
--
-- Parser for WML objects
--
-- Some examples of WML objects are:
--
-- a          // The workspace or window (context dependent) tagged 'a'
-- @a         // All windows on workspace 'a' or the workspace with window 'a'
-- ,.         // The workspace to to the right of the current one.
-- @,.        // All windows on the workspace to the right of the current one.
-- @,^        // All the windows on the screen second from the left
-- &z!~@,,^   // The window tagged with z and The last window on the screen third from the left
-- @@s        // All the windows that share a workspace with the window tagged s
-- \%@s       // All windows except those on workspace 's'
module Rahm.Desktop.Keys.Wml
  ( readWorkspaceMacro,
    readWindowsetMacro,
    readNextWorkspace,
    readNextLocationSet,
    readNextLocationSet',
    moveLocationToWorkspace,
    moveWindowToWorkspaceFn,
    getAndResetWindowSelection,
    gotoWorkspaceFn,
    toggleWindowInSelection,
    addWindowToSelection,
    clearWindowSelection,
    removeWindowFromSelection,
    readMacroString,
    justWorkspace,
    justWorkspaceWithPreferredWindow,
    blackHoleWorkspace,
    alternateWorkspace,
    floatWorkspace,
    joinMaybe,
    feedKeys,
    feedKeysT,
    workspaceForKeysT,
    workspaceForKeys,
    workspaceForStringT,
    workspaceForString,
    locationSetForKeysT,
    locationSetForKeys,
    readNextWorkspaceName,
    workspaceName,
    wmlLogHook,
  )
where

import Control.Monad (forM_, join, void, when)
import Control.Monad.Trans.Class (MonadTrans (lift))
import Control.Monad.Trans.Maybe (MaybeT (..), mapMaybeT)
import Control.Monad.Trans.State as S
  ( StateT (StateT),
    evalStateT,
    get,
    put,
  )
import Data.Char (isAlpha, isAlphaNum, isDigit, ord)
import Data.List (find, intercalate, sortOn)
import Data.List.Safe (head, last)
import Data.Map (Map)
import qualified Data.Map as Map
  ( delete,
    elems,
    empty,
    insert,
    keys,
    lookup,
    member,
  )
import Data.Maybe (catMaybes, fromJust, fromMaybe)
import Data.Ord (Down (..))
import Data.Typeable (cast)
import Rahm.Desktop.Common
  ( Location (..),
    askWindowId,
    getCurrentLocation,
    getCurrentWorkspace,
    gotoWorkspace,
    moveLocationToWorkspace,
    setBorderColor,
    windowsInWorkspace,
  )
import Rahm.Desktop.History
  ( -- getMostRecentLocationInHistory,
    lastLocation,
    nextLocation,
    -- pastHistory,
  )
import Rahm.Desktop.Layout.PinWindow (pinnedWindows)
import Rahm.Desktop.Logger (LogLevel (Info, Trace), logs)
import Rahm.Desktop.Marking
  ( farLeftWindow,
    farRightWindow,
    getAlternateWindows,
    getAlternateWorkspace,
    getMarkedLocations,
    windowLocation,
  )
import qualified Rahm.Desktop.StackSet as W
import Rahm.Desktop.Submap (mapNextStringWithKeysym)
import Rahm.Desktop.Workspaces
  ( accompaningWorkspace,
    adjacentWorkspace,
    adjacentWorkspaceNotVisible,
    getHorizontallyOrderedScreens,
    next,
    prev,
    workspaceWithWindow,
  )
import Rahm.Desktop.XMobarLog.PendingBuffer
  ( addStringToPendingBuffer,
    setPendingBuffer,
  )
import System.Directory (doesFileExist)
import System.Exit (ExitCode (..), exitSuccess, exitWith)
import System.FilePath ((</>))
import System.IO (readFile)
import Text.Printf (printf)
import Text.Read (readMaybe)
import XMonad
  ( Default (def),
    Directories' (dataDir),
    ExtensionClass (..),
    KeyMask,
    KeySym,
    MonadReader (ask),
    StateExtension (PersistentExtension),
    Typeable,
    Window,
    WindowSet,
    WorkspaceId,
    X,
    asks,
    clearArea,
    directories,
    io,
    killWindow,
    windows,
    withWindowSet,
    xK_Escape,
    xK_Return,
  )
import XMonad.Prompt.ConfirmPrompt (confirmPrompt)
import qualified XMonad.Util.ExtensibleState as XS (get, modify, put)
import Prelude hiding (head, last)

type KeyString = [(KeyMask, KeySym, String)]

data MaybeMacros = NoMacros | YesMacros Macros
  deriving (Read, Show)

data Macros = Macros
  { workspaceMacros :: Map (KeyMask, KeySym) KeyString,
    windowsetMacros :: Map (KeyMask, KeySym) KeyString
  }
  deriving (Read, Show)

getMacroDataFile :: X FilePath
getMacroDataFile = asks ((</> "rde-recorded-macros") . dataDir . directories)

getMacros :: X Macros
getMacros = do
  XS.get
    >>= ( \case
            NoMacros -> do
              file <- getMacroDataFile
              exists <- io $ doesFileExist file
              if exists
                then
                  io (readFile file)
                    >>= ( \s ->
                            let macros = fromMaybe (Macros mempty mempty) (readMaybe s :: Maybe Macros)
                             in XS.put (YesMacros macros) >> return macros
                        )
                else return $ Macros mempty mempty
            YesMacros macros -> return macros
        )

saveMacros :: X ()
saveMacros = do
  dataFile <- getMacroDataFile
  macros <- getMacros
  io $ writeFile dataFile $ show macros

selColor = "#b8b880"

selFocusColor = "#ffff00"

insertWorkspaceMacroString :: (KeyMask, KeySym) -> KeyString -> X ()
insertWorkspaceMacroString k ks = do
  macros <- getMacros
  XS.put $
    YesMacros $
      macros
        { workspaceMacros = Map.insert k ks (workspaceMacros macros)
        }
  saveMacros

insertWindowSetMacroString :: (KeyMask, KeySym) -> KeyString -> X ()
insertWindowSetMacroString k ks = do
  macros <- getMacros
  XS.put $
    YesMacros $
      macros
        { windowsetMacros = Map.insert k ks (windowsetMacros macros)
        }
  saveMacros

instance ExtensionClass MaybeMacros where
  initialValue = NoMacros

newtype WindowSelect = WindowSelect (Map Window (X ()))

instance ExtensionClass WindowSelect where
  initialValue = WindowSelect mempty

toggleWindowInSelection :: Window -> X ()
toggleWindowInSelection win = do
  (WindowSelect sel) <- XS.get
  case Map.lookup win sel of
    Nothing -> do
      foc <- withWindowSet (return . W.peek)

      cleanup <-
        setBorderColor
          ( if Just win == foc
              then selFocusColor
              else selColor
          )
          [win]

      XS.put $ WindowSelect $ Map.insert win cleanup sel
    (Just cleanup) -> do
      XS.put $ WindowSelect $ Map.delete win sel
      cleanup

addWindowToSelection :: Window -> X ()
addWindowToSelection win = do
  (WindowSelect sel) <- XS.get
  case Map.lookup win sel of
    Nothing -> do
      foc <- withWindowSet (return . W.peek)

      cleanup <-
        setBorderColor
          ( if Just win == foc
              then selFocusColor
              else selColor
          )
          [win]

      XS.put $ WindowSelect $ Map.insert win cleanup sel
    _ -> return ()

removeWindowFromSelection :: Window -> X ()
removeWindowFromSelection win = do
  (WindowSelect sel) <- XS.get
  case Map.lookup win sel of
    (Just cleanup) -> do
      XS.put $ WindowSelect $ Map.delete win sel
      cleanup
    _ -> return ()

clearWindowSelection :: X ()
clearWindowSelection = void getAndResetWindowSelection

getAndResetWindowSelection :: X [Window]
getAndResetWindowSelection = do
  (WindowSelect mp) <- XS.get
  sequence_ (Map.elems mp)
  XS.put (initialValue :: WindowSelect)
  return (Map.keys mp)

data Workspace = forall a.
  (Typeable a) =>
  Workspace
  { moveWindowToWorkspaceFn :: Window -> X (WindowSet -> WindowSet),
    gotoWorkspaceFn :: X (),
    workspaceName :: Maybe String,
    extraWorkspaceData :: a
  }

readWorkspaceMacro :: MaybeT X ()
readWorkspaceMacro =
  mapNextStringWithKeysym $ \mask sym s -> do
    when (sym == xK_Escape) $
      fail ""

    lift $ setPendingBuffer $ printf "Rec %s " s
    macro <- readMacroString
    lift $ insertWorkspaceMacroString (mask, sym) macro

readWindowsetMacro :: MaybeT X ()
readWindowsetMacro =
  mapNextStringWithKeysym $ \mask sym s -> do
    when (sym == xK_Escape) $
      fail ""

    lift $ setPendingBuffer $ printf "Rec %s " s
    macro <- readMacroString
    lift $ insertWindowSetMacroString (mask, sym) macro

readMacroString :: MaybeT X KeyString
readMacroString = do
  mapNextStringWithKeysym $ \m k s -> case (m, k, s) of
    _ | k == xK_Return -> return []
    _ | k == xK_Escape -> MaybeT $ return Nothing
    r -> do
      lift $ addStringToPendingBuffer s
      ([r] ++) <$> readMacroString

justWorkspace :: String -> Workspace
justWorkspace s =
  Workspace
    { moveWindowToWorkspaceFn = return . W.shiftWin s,
      gotoWorkspaceFn = gotoWorkspace s,
      workspaceName = Just s,
      extraWorkspaceData = ()
    }

justWorkspaceWithPreferredWindow :: Window -> String -> Workspace
justWorkspaceWithPreferredWindow w s =
  Workspace
    { moveWindowToWorkspaceFn = return . W.shiftWin s,
      gotoWorkspaceFn = do
        windows $ \ws' ->
          let ws = W.greedyView s ws'
              l = W.integrate' $ W.stack $ W.workspace $ W.current ws
           in if w `elem` l
                then W.focusWindow w ws
                else ws,
      workspaceName = Just s,
      extraWorkspaceData = ()
    }

blackHoleWorkspace :: Workspace
blackHoleWorkspace =
  Workspace
    { moveWindowToWorkspaceFn = \w -> killWindow w >> return id,
      gotoWorkspaceFn =
        confirmPrompt def "Do you want to exit xmonad" $ io exitSuccess,
      workspaceName = Nothing,
      extraWorkspaceData = ()
    }

alternateWorkspace :: Workspace
alternateWorkspace =
  Workspace
    { moveWindowToWorkspaceFn = \win -> do
        alter <- getAlternateWorkspace win
        return $ \ss ->
          maybe ss (\a -> W.shiftWin a win ss) alter,
      gotoWorkspaceFn = do
        (Location _ maybeWin) <- getCurrentLocation
        case maybeWin of
          Nothing -> return ()
          Just win -> do
            mapM_ gotoWorkspace =<< getAlternateWorkspace win,
      workspaceName = Nothing,
      extraWorkspaceData = ()
    }

newtype FloatWorkspace = FloatWorkspace Workspace

floatWorkspace :: Workspace -> Workspace
floatWorkspace ws@Workspace {extraWorkspaceData = d} =
  Workspace
    { moveWindowToWorkspaceFn = \win -> do
        case cast d of
          Just (FloatWorkspace ws') -> do
            movefn <- moveWindowToWorkspaceFn ws' win
            return $ W.sink win . movefn
          Nothing -> do
            movefn <- moveWindowToWorkspaceFn ws win
            return $ \ss -> do
              if win `Map.member` W.floating ss
                then movefn ss
                else movefn $ W.float win (W.RationalRect (1 / 8) (1 / 8) (6 / 8) (6 / 8)) ss,
      gotoWorkspaceFn = gotoWorkspaceFn ws,
      workspaceName = workspaceName ws,
      extraWorkspaceData = FloatWorkspace ws
    }

joinMaybe :: (Monad m) => MaybeT m (Maybe a) -> MaybeT m a
joinMaybe (MaybeT ma) = MaybeT $ join <$> ma

class (Monad m) => KeyFeeder m where
  fromX :: X a -> m a

  fromMaybeTX :: MaybeT X a -> MaybeT m a
  fromMaybeTX = mapMaybeT fromX

  readNextKey ::
    (KeyMask -> KeySym -> String -> MaybeT m a) -> MaybeT m a

instance KeyFeeder X where
  fromX = id
  readNextKey fn = mapNextStringWithKeysym $
    \mask sym str -> do
      lift $ fromX $ addStringToPendingBuffer str
      fn mask sym str

newtype FeedKeys a = FeedKeys {unFeedKeys :: StateT KeyString X a}
  deriving (Monad, Functor, Applicative)

instance KeyFeeder FeedKeys where
  fromX = FeedKeys . lift

  readNextKey fn = do
    ls <- lift $ FeedKeys S.get
    case ls of
      ((mask, sym, str) : t) -> do
        lift $ FeedKeys $ S.put t
        fn mask sym str
      _ -> MaybeT (return Nothing)

feedKeys :: KeyString -> MaybeT FeedKeys a -> X (Maybe a)
feedKeys s mf = flip evalStateT s . unFeedKeys $ runMaybeT mf

feedKeysT :: KeyString -> MaybeT FeedKeys a -> MaybeT X a
feedKeysT s mf = MaybeT $ feedKeys s mf

-- Allows a reference to a workspace in terms of its description in the window
-- management language.
workspaceForKeysT :: KeyString -> MaybeT X Workspace
workspaceForKeysT str = feedKeysT str readNextWorkspace

-- Like the above, but unwrap the MaybeT
workspaceForKeys :: KeyString -> X (Maybe Workspace)
workspaceForKeys = runMaybeT . workspaceForKeysT

-- Returns a workspace for the given string. Note that workspaces which are
-- defined by special masks and symbols will not work. I.e. macros will not
-- work.
workspaceForStringT :: String -> MaybeT X Workspace
workspaceForStringT = workspaceForKeysT . map (\c -> (def, def, [c]))

workspaceForString :: String -> X (Maybe Workspace)
workspaceForString = runMaybeT . workspaceForStringT

-- Like the above, but unwrap the MaybeT
locationSetForKeysT :: KeyString -> MaybeT X [Location]
locationSetForKeysT s = feedKeysT s readNextLocationSet

locationSetForKeys :: KeyString -> X [Location]
locationSetForKeys s = fromMaybe [] <$> runMaybeT (locationSetForKeysT s)

lift1 :: (KeyFeeder m) => (a -> X b) -> (a -> MaybeT m b)
lift1 = fmap (lift . fromX)

readNextWorkspaceName :: (KeyFeeder m) => MaybeT m WorkspaceId
readNextWorkspaceName = joinMaybe $ workspaceName <$> readNextWorkspace

-- Returns the next workspaces associated with the next set of keystrokes.
readNextWorkspace :: (KeyFeeder m) => MaybeT m Workspace
readNextWorkspace =
  readNextKey $ \mask sym str -> do
    macros <- (lift . fromX) $ workspaceMacros <$> getMacros

    case (mask, sym, str) of
      -- Escape kills the "readNextWorkspace" and returns nothing.
      (_, e, _) | e == xK_Escape -> MaybeT $ return Nothing
      -- Macros takes precedence over everything.
      (mask, keysym, _) | (Just macro) <- Map.lookup (mask, keysym) macros -> do
        fromMaybeTX $ workspaceForKeysT macro

      -- A single alphanumeric character is the atomic reference to a workspace.
      (_, _, [ch]) | isAlphaNum ch || ch == '*' -> return $ justWorkspace [ch]
      -- to the non-visible workspace left of the next workspace.
      (_, _, "[") ->
        justWorkspace
          <$> ( lift1 (adjacentWorkspaceNotVisible prev)
                  =<< readNextWorkspaceName
              )
      -- to the non-visible workspace right of the next workspace
      (_, _, "]") ->
        justWorkspace
          <$> ( lift1 (adjacentWorkspaceNotVisible next)
                  =<< readNextWorkspaceName
              )
      -- To the left of the next workspace
      (_, _, "(") ->
        justWorkspace
          <$> ( lift1 (adjacentWorkspace prev)
                  =<< readNextWorkspaceName
              )
      -- To the right of the next workspace
      (_, _, ")") ->
        justWorkspace
          <$> ( lift1 (adjacentWorkspace next)
                  =<< readNextWorkspaceName
              )
      -- The workspace on the leftmost screen
      (_, _, "^") -> mapMaybeT fromX $
        MaybeT $
          withWindowSet $ \ws ->
            return $
              ( fmap
                  ( justWorkspace . W.tag . W.workspace . snd
                  )
                  . head
              )
                (getHorizontallyOrderedScreens ws)
      -- The last workspace in history.
      (_, _, "'") -> fromMaybeTX $ justWorkspace . locationWorkspace <$> MaybeT lastLocation
      -- The current workspace.
      (_, _, ".") -> mt $ justWorkspace <$> getCurrentWorkspace
      -- The workspace on the rightmost screen
      (_, _, "$") -> MaybeT $
        fromX $
          withWindowSet $ \ws ->
            return $
              (fmap (justWorkspace . W.tag . W.workspace . snd) . last)
                (getHorizontallyOrderedScreens ws)
      -- Modify the next workspace as a "floating" workspace. (Windows sent to
      -- it will float).
      (_, _, ":") -> floatWorkspace <$> readNextWorkspace
      -- Workspace to the next screen to the right of the next workspace.
      (_, _, ",") -> do
        ws <- readNextWorkspace
        screens <-
          mt $
            map (W.tag . W.workspace . snd)
              <$> withWindowSet (return . getHorizontallyOrderedScreens)

        let (_, rest) = break ((== workspaceName ws) . Just) (screens ++ screens)

        justWorkspace <$> MaybeT (return $ head $ tail rest)

      -- Workspace to the next screen to the left of the next workspace.
      (_, _, ";") -> do
        ws <- readNextWorkspace
        screens <-
          mt $
            map (W.tag . W.workspace . snd)
              <$> withWindowSet (return . getHorizontallyOrderedScreens)

        let (front, _) = break ((== workspaceName ws) . Just) (screens ++ screens)

        justWorkspace <$> MaybeT (return $ last front)

      -- The workspace with the searched for window.
      (_, _, "/") -> fromMaybeTX $ do
        justWorkspace <$> ((MaybeT . workspaceWithWindow) =<< MaybeT ((head =<<) <$> askWindowId))

      -- The workspace with the next read window on it.
      (_, _, "@") -> do
        loc <- readNextLocationSet
        MaybeT $
          fromX $
            withWindowSet $ \ws -> return $ do
              win <- locationWindow =<< head loc
              winLocation <- W.findWindow ws win
              justWorkspaceWithPreferredWindow win . W.tag <$> W.getLocationWorkspace winLocation

      -- The accompaning worksapce to the next read workspace.
      (_, _, "~") ->
        justWorkspace . accompaningWorkspace <$> readNextWorkspaceName
      -- The accompaning workspace to the current workspace (equivalent to ~.)
      (_, _, " ") ->
        mt $
          justWorkspace . accompaningWorkspace <$> getCurrentWorkspace
      -- The balck hole workspace
      (_, _, "_") -> return blackHoleWorkspace
      -- The alternate workspace
      (_, _, "-") -> return alternateWorkspace
      -- If the next two read workspaces are equal, go to the third workspace
      -- otherwise go to the fourth workspace.
      (_, _, "=") -> do
        ws1 <- readNextWorkspace
        ws2 <- readNextWorkspace

        ws3 <- readNextWorkspace
        ws4 <- readNextWorkspace

        return $
          if workspaceName ws1 == workspaceName ws2
            then ws3
            else ws4

      -- If the next read location set is not empty, go to the next read
      -- workspace, otherwise go to the next-next read workspace.
      (_, _, "?") -> do
        l1 <- readNextLocationSet

        ws1 <- readNextWorkspace
        ws2 <- readNextWorkspace

        mt $ logs Trace "If not empty %s then %s else %s" (show l1) (show $ workspaceName ws1) (show $ workspaceName ws2)

        return $
          if null l1
            then ws2
            else ws1
      _ -> MaybeT (return Nothing)
  where
    mt :: (KeyFeeder m) => X a -> MaybeT m a
    mt = lift . fromX

readNextLocationSet :: (KeyFeeder m) => MaybeT m [Location]
readNextLocationSet = do
  (WindowSelect mp) <- MaybeT (Just <$> fromX XS.get)
  case Map.keys mp of
    [] -> readNextLocationSet'
    wins -> do
      lift $ fromX $ addStringToPendingBuffer "<sel> "
      fromMaybeTX $
        mapM windowLocation
          =<< MaybeT (Just <$> fromX getAndResetWindowSelection)

-- Like readNextLocationSet, but ignores the window selection.
readNextLocationSet' :: (KeyFeeder m) => MaybeT m [Location]
readNextLocationSet' =
  readNextKey $ \mask sym str -> do
    macros <- (lift . fromX) $ windowsetMacros <$> getMacros

    case (mask, sym, str) of
      -- Escape returns nothing and aborts reading the next location.
      (_, e, _) | e == xK_Escape -> MaybeT $ return Nothing
      -- Macros takes precedence.
      (mask, keysym, _) | (Just macro) <- Map.lookup (mask, keysym) macros -> do
        fromMaybeTX $ locationSetForKeysT macro

      -- A character is the base-case. Refers to a collection of windows.
      (_, _, [ch]) | isAlpha ch -> mt $ getMarkedLocations [ch]
      -- Goes to the most recent location in history.
      -- (_, _, "0") -> (: []) <$> MaybeT (fromX getMostRecentLocationInHistory)
      -- A Digit goes to the past history.
      -- (_, _, [ch])
      --   | isDigit ch ->
      --     (: []) <$> MaybeT (fromX $ pastHistory (ord ch - 0x30))
      -- The current window.
      (_, _, ".") -> (: []) <$> mt getCurrentLocation
      -- The selected windows in the selection set.
      (_, _, "#") ->
        MaybeT . fromX $ Just . map (Location "*" . Just) <$> pinnedWindows
      -- The window on the far-left of the screens.
      (_, _, "^") -> (: []) <$> fromMaybeTX farLeftWindow
      -- The windows on the far-right of the screens.
      (_, _, "$") -> (: []) <$> fromMaybeTX farRightWindow
      -- The next location in history.
      (_, _, "\"") -> (: []) <$> MaybeT (fromX nextLocation)
      -- The previous location in history.
      (_, _, "'") -> (: []) <$> MaybeT (fromX lastLocation)
      -- All visible windows.
      (_, _, "*") -> mt $ do
        wins <- withWindowSet $ return . W.allVisibleWindows
        catMaybes <$> mapM (runMaybeT . windowLocation) wins

      -- The last referenced windows.
      (_, _, "-") ->
        fromMaybeTX $
          mapM windowLocation =<< lift getAlternateWindows
      -- Search for the windows.
      (_, _, "/") ->
        fromMaybeTX $
          mapM windowLocation =<< MaybeT askWindowId
      -- All windows.
      (_, _, "%") -> fromMaybeTX $ do
        ret <- mapM windowLocation =<< lift (withWindowSet (return . sortOn Down . W.allWindows))
        lift $ logs Info "allWindows %s" (intercalate "\n" (map show ret))
        return ret

      -- Windows in a workspace
      (_, _, s)
        | s == "\t" || s == "@" || s == "\n" ->
          (mt . windowsInWorkspace) =<< readNextWorkspaceName
      -- The first window in the next window set.
      (_, _, "!") -> (: []) <$> joinMaybe (head <$> readNextLocationSet)
      -- The windows except the first in a window set.
      (_, _, ",") -> tail <$> readNextLocationSet
      -- The next window set, but reversed
      (_, _, "~") -> reverse <$> readNextLocationSet
      -- All the floating windows
      (_, _, ":") ->
        mt $
          withWindowSet $
            fmap catMaybes
              . mapM (runMaybeT . windowLocation)
              . Map.keys
              . W.floating
      -- If the next read window set is not empty, then this location
      -- otherwise the next read location.
      (_, _, "?") -> do
        l1 <- readNextLocationSet
        l2 <- readNextLocationSet
        return $ if null l1 then l2 else l1

      -- The next window set unioned with the next location set
      (_, _, "|") -> do
        l1 <- readNextLocationSet
        l2 <- readNextLocationSet
        return (l1 ++ l2)

      -- Empty window set.
      (_, _, "_") -> return []
      -- The next location set differenced with the next-next location set
      (_, _, "\\") -> do
        l1 <- readNextLocationSet
        l2 <- readNextLocationSet
        return $ filter (not . flip elem l2) l1

      -- The next location set intersected with the next-next location set
      (_, _, "&") -> do
        l1 <- readNextLocationSet
        l2 <- readNextLocationSet
        return $ filter (`elem` l2) l1
      _ -> MaybeT (return Nothing)
  where
    mt :: (KeyFeeder m) => X a -> MaybeT m a
    mt = lift . fromX

wmlLogHook :: X ()
wmlLogHook = do
  -- Reset the border colors for the selected window.
  (WindowSelect (Map.keys -> sel)) <- XS.get
  foc <- (withWindowSet (return . fromMaybe (0 :: Window) . W.peek) :: X Window)
  void $ setBorderColor selColor (filter (/= foc) sel)
  mapM_ (setBorderColor selFocusColor . (: [])) (find (== foc) sel)