Reduce.hs

module YMonad.Core.Reduce (
  reduce,
  relayoutRequests,
) where

import Data.List (partition)
import Data.Map.Strict qualified as M

import YMonad.Core.Layout
import YMonad.Core.StackSet
import YMonad.Core.Types

reduce :: RuntimeState -> YEvent -> Transition
reduce st ev = case ev of
  EvViewMapped vid meta ->
    let ws' = insertUp vid (rtWindowSet st)
        st' = st {rtWindowSet = ws', rtViews = M.insert vid meta (rtViews st)}
     in Transition st' (relayoutRequests st')
  EvViewUnmapped vid ->
    let ws' = delete vid (rtWindowSet st)
        st' = st {rtWindowSet = ws', rtViews = M.delete vid (rtViews st)}
     in Transition st' (ReqHideView vid : relayoutRequests st')
  EvOutputAdded oid info ->
    let currentScreen = current (rtWindowSet st)
        ws' =
          (rtWindowSet st)
            { current = currentScreen {screenRect = outputRect info}
            }
        st' = st {rtWindowSet = ws', rtOutputs = M.insert oid info (rtOutputs st)}
     in Transition st' (relayoutRequests st')
  EvOutputRemoved oid ->
    let st' = st {rtOutputs = M.delete oid (rtOutputs st)}
     in Transition st' []
  EvFocusChanged Nothing -> Transition st [ReqFocusView Nothing, ReqCommit]
  EvFocusChanged (Just vid) ->
    let ws' = focusWindow vid (rtWindowSet st)
        st' = st {rtWindowSet = ws'}
     in Transition st' (relayoutRequests st')
  EvUserCommand cmd -> reduceCommand st cmd
  EvBackendFault fault -> Transition (st {rtLastFault = Just fault}) []

reduceCommand :: RuntimeState -> UserCommand -> Transition
reduceCommand st cmd = case cmd of
  CmdFocusNext ->
    let st' = st {rtWindowSet = focusUp (rtWindowSet st)}
     in Transition st' (relayoutRequests st')
  CmdFocusPrev ->
    let st' = st {rtWindowSet = focusDown (rtWindowSet st)}
     in Transition st' (relayoutRequests st')
  CmdSwapNext ->
    let st' = st {rtWindowSet = swapUp (rtWindowSet st)}
     in Transition st' (relayoutRequests st')
  CmdSwapPrev ->
    let st' = st {rtWindowSet = swapDown (rtWindowSet st)}
     in Transition st' (relayoutRequests st')
  CmdKillFocused -> case peek (rtWindowSet st) of
    Nothing -> Transition st []
    Just vid -> Transition st [ReqCloseView vid, ReqCommit]
  CmdViewWorkspace wid ->
    let st' = st {rtWindowSet = view wid (rtWindowSet st)}
     in Transition st' (relayoutRequests st')
  CmdMoveFocusedTo wid ->
    let st' = st {rtWindowSet = shift wid (rtWindowSet st)}
     in Transition st' (relayoutRequests st')
  CmdToggleFullscreen -> toggleCurrentWorkspaceFullscreen st
  CmdCycleLayout -> applyCurrentLayoutMessage (MsgChangeLayout NextLayout) st
  CmdShrink -> applyCurrentLayoutMessage (MsgResize Shrink) st
  CmdExpand -> applyCurrentLayoutMessage (MsgResize Expand) st
  CmdIncMasterN delta -> applyCurrentLayoutMessage (MsgIncMasterN (IncMasterN delta)) st
  CmdExitSession -> Transition st [ReqExitSession]

applyCurrentLayoutMessage :: LayoutMessage -> RuntimeState -> Transition
applyCurrentLayoutMessage message st =
  let ws' =
        modifyCurrentWorkspace
          ( \workspace ->
              let oldLayout = workspaceLayout workspace
                  newLayout = applyLayoutMessage message oldLayout
                  restoreLayout =
                    if description oldLayout == "Full" && description newLayout /= "Full"
                      then Nothing
                      else workspaceRestoreLayout workspace
               in workspace
                    { workspaceLayout = newLayout
                    , workspaceRestoreLayout = restoreLayout
                    }
          )
          (rtWindowSet st)
      st' = st {rtWindowSet = ws'}
   in Transition st' (relayoutRequests st')

relayoutRequests :: RuntimeState -> [BackendReq]
relayoutRequests st = map mkShow placementPairs ++ styleRequests ++ hideRequests ++ focusRequest ++ [ReqCommit]
  where
    currentScreen = current (rtWindowSet st)
    currentWorkspace = screenWorkspace currentScreen
    placements = layoutViews (workspaceLayout currentWorkspace) (screenRect currentScreen) (workspaceStack currentWorkspace)
    placementPairs = focusFirst focusedView placements
    active = map fst placementPairs
    hideRequests = [ReqHideView vid | vid <- M.keys (rtViews st), vid `notElem` active]
    focusRequest = case focusedView of
      Nothing -> [ReqFocusView Nothing]
      Just vid -> [ReqFocusView (Just vid)]
    styleRequests = map mkStyle active
    focusedView = peek (rtWindowSet st)
    theme = rtTheme st

    mkShow (vid, rect) = ReqSetViewRect vid rect
    mkStyle vid =
      ReqSetViewStyle
        vid
        ViewStyle
          { viewStyleTitleBarMode = themeTitleBarMode theme
          , viewStyleBorderWidth = themeBorderWidth theme
          , viewStyleBorderColor = if Just vid == focusedView then themeFocusedBorderColor theme else themeNormalBorderColor theme
          }

toggleCurrentWorkspaceFullscreen :: RuntimeState -> Transition
toggleCurrentWorkspaceFullscreen st =
  let ws' =
        modifyCurrentWorkspace
          ( \workspace ->
              let currentLayout = workspaceLayout workspace
               in if description currentLayout == "Full"
                    then
                      workspace
                        { workspaceLayout = fromMaybe currentLayout (workspaceRestoreLayout workspace)
                        , workspaceRestoreLayout = Nothing
                        }
                    else
                      workspace
                        { workspaceLayout = applyLayoutMessage (MsgJumpToLayout "Full") currentLayout
                        , workspaceRestoreLayout = Just currentLayout
                        }
          )
          (rtWindowSet st)
      st' = st {rtWindowSet = ws'}
   in Transition st' (relayoutRequests st')

focusFirst :: (Eq a) => Maybe a -> [(a, b)] -> [(a, b)]
focusFirst Nothing xs = xs
focusFirst (Just focused) xs = focusedPairs ++ otherPairs
  where
    (focusedPairs, otherPairs) = partition ((== focused) . fst) xs