{-# LANGUAGE DeriveAnyClass #-}

module Rahm.Desktop.Layout.Bordering
  ( Bordering (..),
    banishToBorder,
    unbanish,
    rotateBorderForward,
    rotateBorderBackward,
    bordering,
    toggleBanish,
    changeWidth,
    changeHeight,
    moveForward,
    moveBackward,
  )
where

import Control.Arrow
import Control.Monad
import Data.List (find, partition)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (fromMaybe)
import Data.Proxy (Proxy)
import qualified Data.Set as Set
import Data.Tuple (swap)
import Data.Typeable (cast)
import Rahm.Desktop.Logger
import qualified Rahm.Desktop.StackSet as W
import XMonad

data BorderPosition
  = North
  | NorthEast
  | East
  | SouthEast
  | South
  | SouthWest
  | West
  | NorthWest
  deriving (Eq, Show, Read, Ord, Enum, Bounded)

data BorderingData a = BorderingData
  { extraWindows :: Map BorderPosition a,
    borderingWidth :: Rational,
    borderingHeight :: Rational,
    borderingPadding :: Int
  }
  deriving (Eq, Ord, Show, Read)

data Bordering (l :: * -> *) (a :: *) = Bordering
  { borderingData :: BorderingData a,
    wrappedLayout :: l a
  }
  deriving (Eq, Ord, Show, Read)

data ModifyBordering a
  = ModifyBordering (BorderingData a -> BorderingData a)
  deriving (Message)

enumNext :: (Eq a, Enum a, Bounded a) => a -> a
enumNext a
  | a == maxBound = minBound
  | otherwise = succ a

enumPrev :: (Eq a, Enum a, Bounded a) => a -> a
enumPrev a
  | a == minBound = maxBound
  | otherwise = pred a

bordering :: l a -> Bordering l a
bordering = Bordering (BorderingData mempty (1 / 6) (1 / 6) 10)

banishToBorder :: a -> ModifyBordering a
banishToBorder win =
  let allPositions =
        (\(a, b) -> b ++ a) $ break (== SouthEast) [minBound .. maxBound]
   in ModifyBordering $ \dat ->
        maybe
          dat
          ( \pos ->
              dat {extraWindows = Map.insert pos win (extraWindows dat)}
          )
          $ find (not . (`Map.member` extraWindows dat)) allPositions

toggleBanish :: (Eq a) => a -> ModifyBordering a
toggleBanish win = ModifyBordering $ \dat ->
  let (ModifyBordering fn) =
        if elem win $ Map.elems $ extraWindows dat
          then unbanish win
          else banishToBorder win
   in fn dat

unbanish :: (Eq a) => a -> ModifyBordering a
unbanish win =
  ModifyBordering $ \dat ->
    maybe
      dat
      (\pos -> dat {extraWindows = Map.delete pos (extraWindows dat)})
      $ (fst <$> find ((== win) . snd) (Map.toList $ extraWindows dat))

rotateBorder :: (BorderPosition -> BorderPosition) -> ModifyBordering a
rotateBorder next = ModifyBordering $ \dat ->
  dat {extraWindows = Map.mapKeys next (extraWindows dat)}

rotateBorderForward :: Proxy a -> ModifyBordering a
rotateBorderForward _ = rotateBorder enumNext

rotateBorderBackward :: Proxy a -> ModifyBordering a
rotateBorderBackward _ = rotateBorder enumPrev

changeWidth :: Proxy a -> Rational -> ModifyBordering a
changeWidth _ amt = ModifyBordering $ \dat ->
  dat {borderingWidth = guard $ borderingWidth dat + amt}
  where
    guard x
      | x < 1 / 12 = 1 / 12
      | x > 4 / 12 = 4 / 12
      | otherwise = x

changeHeight :: Proxy a -> Rational -> ModifyBordering a
changeHeight _ amt = ModifyBordering $ \dat ->
  dat {borderingHeight = guard $ borderingHeight dat + amt}
  where
    guard x
      | x < 1 / 12 = 1 / 12
      | x > 4 / 12 = 4 / 12
      | otherwise = x

instance Semigroup (ModifyBordering a) where
  (<>) = mappend

instance Monoid (ModifyBordering a) where
  mempty = ModifyBordering id
  mappend (ModifyBordering f1) (ModifyBordering f2) = ModifyBordering (f2 . f1)

move :: (Eq a) => (BorderPosition -> BorderPosition) -> a -> ModifyBordering a
move fn win = ModifyBordering $ \dat ->
  let mKey = fst <$> find ((== win) . snd) (Map.toList $ extraWindows dat)
   in case mKey of
        Nothing -> dat
        Just key ->
          let newKey =
                until
                  (\k -> not (Map.member k (extraWindows dat) && k /= key))
                  fn
                  (fn key)
              wins' = Map.insert newKey win $ Map.delete key $ extraWindows dat
           in dat {extraWindows = wins'}

moveForward :: (Eq a) => a -> ModifyBordering a
moveForward = move enumNext

moveBackward :: (Eq a) => a -> ModifyBordering a
moveBackward = move enumPrev

instance (Show a, Ord a, LayoutClass l a, Typeable a) => LayoutClass (Bordering l) a where
  runLayout (W.Workspace t (Bordering dat l) as) rect = do
    let (out, rest) = filterStack as
    (rects, maybeNewLayout) <- runLayout (W.Workspace t l rest) rect
    return (layoutRest out ++ rects, Bordering dat <$> maybeNewLayout)
    where
      filterStack Nothing = ([], Nothing)
      filterStack (Just (W.Stack f h t)) = do
        let elSet = Set.fromList (Map.elems $ extraWindows dat)
            ((hp, h'), (tp, t')) = dbl (partition (`Set.member` elSet)) (h, t)
         in case (Set.member f elSet, h', t', hp ++ tp) of
              (False, _, _, r) -> (r, Just $ W.Stack f h' t')
              (True, (a : h''), _, r) -> (f : r, Just $ W.Stack a h'' t')
              (True, [], (a : t''), r) -> (f : r, Just $ W.Stack a [] t'')
              (True, [], [], r) -> (f : r, Nothing)

      layoutRest windows =
        map (second (scaleRationalRect (padRect rect) . loc2Rect) . swap) $
          filter ((`elem` windows) . snd) $
            Map.toList (extraWindows dat)

      padRect (Rectangle x y w h) =
        let p :: (Integral a) => a
            p = fromIntegral (borderingPadding dat)
         in Rectangle (x + p) (y + p) (w - p * 2) (h - p * 2)

      loc2Rect loc = case loc of
        North -> W.RationalRect (1 / 2 - (bw / 2)) 0 bw bh
        NorthEast -> W.RationalRect (1 - bw) 0 bw bh
        East -> W.RationalRect (1 - bw) (1 / 2 - (bh / 2)) bw bh
        SouthEast -> W.RationalRect (1 - bw) (1 - bh) bw bh
        South -> W.RationalRect (1 / 2 - (bw / 2)) (1 - bh) bw bh
        SouthWest -> W.RationalRect 0 (1 - bh) bw bh
        West -> W.RationalRect 0 (1 / 2 - (bh / 2)) bw bh
        NorthWest -> W.RationalRect 0 0 bw bh
        where
          bw = borderingWidth dat
          bh = borderingHeight dat

      dbl f = f *** f

  handleMessage (Bordering d l) m@(fromMessage -> Just e@DestroyWindowEvent {ev_window = w}) = do
    maybeNewLayout <- handleMessage l m
    return $ Just $ Bordering (f d) (fromMaybe l maybeNewLayout)
    where
      f e@BorderingData {extraWindows = ws} =
        e {extraWindows = Map.filter (maybe True (/= w) . cast) ws}
  handleMessage (Bordering d l) (fromMessage -> Just (ModifyBordering fn)) =
    return (Just $ Bordering (fn d) l)
  handleMessage (Bordering d l) a = do
    maybeNewLayout <- handleMessage l a
    return (Bordering d <$> maybeNewLayout)