Layout.hs

module YMonad.Core.Layout (
  Border (..),
  Layout (..),
  Resize (..),
  IncMasterN (..),
  ChangeLayout (..),
  CLR (..),
  LayoutMessage (..),
  tall,
  full,
  mirror,
  spacingRaw,
  spacing,
  spacingWithEdge,
  smartSpacing,
  smartSpacingWithEdge,
  (|||),
  description,
  applyLayoutMessage,
  layoutViews,
  mirrorRect,
  splitVertically,
  splitHorizontally,
  splitHorizontallyBy,
  splitVerticallyBy,
  tile,
) where

import Data.Ratio ((%))

import YMonad.Core.Common (Rect (..))
import YMonad.Core.StackSet (Stack (..), integrate)

data Border = Border
  { borderTop :: Int
  , borderBottom :: Int
  , borderRight :: Int
  , borderLeft :: Int
  }
  deriving stock (Eq, Ord, Show, Read)

data Resize = Shrink | Expand
  deriving stock (Eq, Ord, Show, Read)

newtype IncMasterN = IncMasterN Int
  deriving stock (Eq, Ord, Show, Read)

data ChangeLayout = FirstLayout | NextLayout
  deriving stock (Eq, Ord, Show, Read)

data CLR = CL | CR
  deriving stock (Eq, Ord, Show, Read)

data LayoutMessage
  = MsgResize Resize
  | MsgIncMasterN IncMasterN
  | MsgChangeLayout ChangeLayout
  | MsgJumpToLayout Text
  deriving stock (Eq, Ord, Show, Read)

data Layout
  = Full
  | Tall
      { tallNMaster :: Int
      , tallRatioIncrement :: Rational
      , tallRatio :: Rational
      }
  | Mirror Layout
  | Choose CLR Layout Layout
  | Spacing
      { spacingSmartBorder :: Bool
      , spacingScreenBorder :: Border
      , spacingScreenBorderEnabled :: Bool
      , spacingWindowBorder :: Border
      , spacingWindowBorderEnabled :: Bool
      , spacingInnerLayout :: Layout
      }
  deriving stock (Eq, Ord, Show, Read)

full :: Layout
full = Full

tall :: Layout
tall = Tall 1 (3 % 100) (1 % 2)

mirror :: Layout -> Layout
mirror = Mirror

spacingRaw :: Bool -> Border -> Bool -> Border -> Bool -> Layout -> Layout
spacingRaw = Spacing

spacing :: Int -> Layout -> Layout
spacing px = spacingRaw False zeroBorder False (uniformBorder px) True

spacingWithEdge :: Int -> Layout -> Layout
spacingWithEdge px = spacingRaw False (uniformBorder px) True (uniformBorder px) True

smartSpacing :: Int -> Layout -> Layout
smartSpacing px = spacingRaw True zeroBorder False (uniformBorder px) True

smartSpacingWithEdge :: Int -> Layout -> Layout
smartSpacingWithEdge px = spacingRaw True (uniformBorder px) True (uniformBorder px) True

(|||) :: Layout -> Layout -> Layout
(|||) = Choose CL
infixr 5 |||

description :: Layout -> Text
description layout = case layout of
  Full -> "Full"
  Tall {} -> "Tall"
  Mirror inner -> "Mirror " <> description inner
  Choose CL left _ -> description left
  Choose CR _ right -> description right
  Spacing {spacingInnerLayout = inner} -> description inner

applyLayoutMessage :: LayoutMessage -> Layout -> Layout
applyLayoutMessage message layout =
  case message of
    MsgResize resize -> applyResize resize layout
    MsgIncMasterN delta -> applyIncMaster delta layout
    MsgChangeLayout FirstLayout -> firstLayout layout
    MsgChangeLayout NextLayout -> nextLayout layout
    MsgJumpToLayout name -> fromMaybe layout (jumpToLayout name layout)

layoutViews :: Layout -> Rect -> Maybe (Stack a) -> [(a, Rect)]
layoutViews _ _ Nothing = []
layoutViews layout rect (Just stack) =
  case layout of
    Full -> [(stackFocus stack, rect)]
    Tall nmaster _ frac ->
      let windows = integrate stack
       in zip windows (tile frac rect nmaster (length windows))
    Mirror inner -> map (second mirrorRect) (layoutViews inner (mirrorRect rect) (Just stack))
    Choose CL left _ -> layoutViews left rect (Just stack)
    Choose CR _ right -> layoutViews right rect (Just stack)
    Spacing smart screenBorder screenEnabled windowBorder windowEnabled inner ->
      let windows = integrate stack
          applyBorders = not smart || length windows >= 2
          parentRect =
            if applyBorders && screenEnabled
              then insetRect screenBorder rect
              else rect
          childViews = layoutViews inner parentRect (Just stack)
       in if applyBorders && windowEnabled
            then map (second (insetRect windowBorder)) childViews
            else childViews

applyResize :: Resize -> Layout -> Layout
applyResize resize layout = case layout of
  Tall nmaster delta frac ->
    Tall nmaster delta (clampRatio (case resize of Shrink -> frac - delta; Expand -> frac + delta))
  Mirror inner -> Mirror (applyResize resize inner)
  Choose CL left right -> Choose CL (applyResize resize left) right
  Choose CR left right -> Choose CR left (applyResize resize right)
  Spacing smart screenBorder screenEnabled windowBorder windowEnabled inner ->
    Spacing smart screenBorder screenEnabled windowBorder windowEnabled (applyResize resize inner)
  Full -> Full

applyIncMaster :: IncMasterN -> Layout -> Layout
applyIncMaster (IncMasterN delta) layout = case layout of
  Tall nmaster ratioIncrement frac -> Tall (max 0 (nmaster + delta)) ratioIncrement frac
  Mirror inner -> Mirror (applyIncMaster (IncMasterN delta) inner)
  Choose CL left right -> Choose CL (applyIncMaster (IncMasterN delta) left) right
  Choose CR left right -> Choose CR left (applyIncMaster (IncMasterN delta) right)
  Spacing smart screenBorder screenEnabled windowBorder windowEnabled inner ->
    Spacing smart screenBorder screenEnabled windowBorder windowEnabled (applyIncMaster (IncMasterN delta) inner)
  Full -> Full

firstLayout :: Layout -> Layout
firstLayout layout = case layout of
  Choose _ left right -> Choose CL (firstLayout left) (firstLayout right)
  Mirror inner -> Mirror (firstLayout inner)
  Spacing smart screenBorder screenEnabled windowBorder windowEnabled inner ->
    Spacing smart screenBorder screenEnabled windowBorder windowEnabled (firstLayout inner)
  _ -> layout

nextLayout :: Layout -> Layout
nextLayout layout = fromMaybe (firstLayout layout) (nextLayoutNoWrap layout)

nextLayoutNoWrap :: Layout -> Maybe Layout
nextLayoutNoWrap layout = case layout of
  Full -> Nothing
  Tall {} -> Nothing
  Mirror inner -> Mirror <$> nextLayoutNoWrap inner
  Choose CL left right ->
    case nextLayoutNoWrap left of
      Just left' -> Just (Choose CL left' right)
      Nothing -> Just (Choose CR (firstLayout left) (firstLayout right))
  Choose CR left right ->
    Choose CR left <$> nextLayoutNoWrap right
  Spacing smart screenBorder screenEnabled windowBorder windowEnabled inner ->
    Spacing smart screenBorder screenEnabled windowBorder windowEnabled <$> nextLayoutNoWrap inner

jumpToLayout :: Text -> Layout -> Maybe Layout
jumpToLayout name layout
  | description layout == name = Just layout
  | otherwise =
      case layout of
        Mirror inner -> Mirror <$> jumpToLayout name inner
        Choose _ left right ->
          let left' = fromMaybe left (jumpToLayout name left)
              right' = fromMaybe right (jumpToLayout name right)
           in if description left' == name
                then Just (Choose CL left' right')
                else
                  if description right' == name
                    then Just (Choose CR left' right')
                    else Nothing
        Spacing smart screenBorder screenEnabled windowBorder windowEnabled inner ->
          Spacing smart screenBorder screenEnabled windowBorder windowEnabled <$> jumpToLayout name inner
        _ -> Nothing

clampRatio :: Rational -> Rational
clampRatio = max 0 . min 1

tile :: Rational -> Rect -> Int -> Int -> [Rect]
tile frac rect nmaster n
  | n <= 0 = []
  | n <= nmaster || nmaster == 0 = splitVertically n rect
  | otherwise = splitVertically nmaster masterRect ++ splitVertically (n - nmaster) stackRect
  where
    (masterRect, stackRect) = splitHorizontallyBy (clampRatio frac) rect

splitVertically :: Int -> Rect -> [Rect]
splitVertically n rect
  | n <= 0 = []
  | n < 2 = [rect]
  | otherwise = firstRect : splitVertically (n - 1) remainderRect
  where
    smallHeight = rectHeight rect `div` n
    firstRect =
      Rect
        { rectX = rectX rect
        , rectY = rectY rect
        , rectWidth = rectWidth rect
        , rectHeight = smallHeight
        }
    remainderRect =
      Rect
        { rectX = rectX rect
        , rectY = rectY rect + smallHeight
        , rectWidth = rectWidth rect
        , rectHeight = rectHeight rect - smallHeight
        }

splitHorizontally :: Int -> Rect -> [Rect]
splitHorizontally n = map mirrorRect . splitVertically n . mirrorRect

splitHorizontallyBy :: Rational -> Rect -> (Rect, Rect)
splitHorizontallyBy frac rect =
  ( Rect
      { rectX = rectX rect
      , rectY = rectY rect
      , rectWidth = leftWidth
      , rectHeight = rectHeight rect
      }
  , Rect
      { rectX = rectX rect + leftWidth
      , rectY = rectY rect
      , rectWidth = rectWidth rect - leftWidth
      , rectHeight = rectHeight rect
      }
  )
  where
    leftWidth = floor (fromIntegral (rectWidth rect) * frac)

splitVerticallyBy :: Rational -> Rect -> (Rect, Rect)
splitVerticallyBy frac = both mirrorRect . splitHorizontallyBy frac . mirrorRect

mirrorRect :: Rect -> Rect
mirrorRect rect =
  Rect
    { rectX = rectY rect
    , rectY = rectX rect
    , rectWidth = rectHeight rect
    , rectHeight = rectWidth rect
    }

both :: (a -> b) -> (a, a) -> (b, b)
both f (x, y) = (f x, f y)

uniformBorder :: Int -> Border
uniformBorder px = Border px px px px

zeroBorder :: Border
zeroBorder = uniformBorder 0

insetRect :: Border -> Rect -> Rect
insetRect border rect =
  Rect
    { rectX = rectX rect + left
    , rectY = rectY rect + top
    , rectWidth = max 0 (rectWidth rect - left - right)
    , rectHeight = max 0 (rectHeight rect - top - bottom)
    }
  where
    top = max 0 (borderTop border)
    bottom = max 0 (borderBottom border)
    right = max 0 (borderRight border)
    left = max 0 (borderLeft border)