{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

-- Delegates to a lower layout, but leaves a hole where the next window will go.
module Rahm.Desktop.Layout.Hole
  ( hole,
    addHoleForWindow,
    removeHoleForWindow,
    resetHole,
    addHole,
  )
where

import Control.Monad (forM_)
import Data.List (intercalate, sortOn)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (fromMaybe)
import Rahm.Desktop.Logger (LogLevel (Debug, Trace), logs)
import Rahm.Desktop.StackSet (TilePosition (TilePosition))
import qualified Rahm.Desktop.StackSet as W
import XMonad
  ( LayoutClass (handleMessage, runLayout),
    Message,
    Window,
    WorkspaceId,
    X,
    fromMessage,
  )

data Hole (l :: * -> *) (a :: *)
  = Hole (Map WorkspaceId [(W.TilePosition WorkspaceId, Maybe Window)]) (l a)

deriving instance (Show (l a)) => Show (Hole l a)

deriving instance (Read (l a)) => Read (Hole l a)

hole :: l a -> Hole l a
hole = Hole mempty

resetHole :: ManageHole
resetHole = ManageHole $ \(Hole _ l) -> Hole mempty l

addHoleForWindow :: W.TilePosition WorkspaceId -> Window -> ManageHole
addHoleForWindow p@(W.TilePosition wid _) win = ManageHole $ \(Hole m l) ->
  Hole
    ( Map.alter
        ( \(fromMaybe [] -> existing) ->
            Just $ (p, Just win) : existing
        )
        wid
        m
    )
    l

addHole :: W.TilePosition WorkspaceId -> ManageHole
addHole p@(W.TilePosition wid _) = ManageHole $ \(Hole m l) ->
  Hole
    ( Map.alter
        ( \(fromMaybe [] -> existing) ->
            Just $ (p, Nothing) : existing
        )
        wid
        m
    )
    l

removeHoleForWindow :: Window -> ManageHole
removeHoleForWindow win = ManageHole $ \(Hole m l) ->
  Hole
    ( Map.mapMaybe
        (Just . filter ((/= Just win) . snd))
        m
    )
    l

dbgHole :: Hole l a -> X ()
dbgHole (Hole mp _) = do
  logs Debug "Hole:"
  forM_ (Map.toList mp) $ \(wid, poses) ->
    logs Debug "  wid[%s] - [%s]" wid $
      intercalate
        ","
        ( map (\(TilePosition _ n, w) -> show w ++ "@" ++ show n) poses
        )

maxWindow :: Window
maxWindow = maxBound

data ManageHole where
  ManageHole :: (forall l a. Hole l a -> Hole l a) -> ManageHole
  deriving (Message)

instance (LayoutClass l a, a ~ Window) => LayoutClass (Hole l) a where
  runLayout (W.Workspace t h@(Hole holes l) a) rect = do
    dbgHole h
    (rects, maybeNewLayout) <- runLayout (app holes $ W.Workspace t l a) rect
    return (filter ((> 0) . fst) rects, fmap (Hole holes) maybeNewLayout)
    where
      app ::
        (Ord i1) =>
        Map i1 [(TilePosition i, Maybe Window)] ->
        W.Workspace i1 l1 Window ->
        W.Workspace i1 l1 Window
      app mp (W.Workspace t l (Just s))
        | Just positions <- sortIt <$> Map.lookup t mp =
            let positionToFakes =
                  zipWith
                    (\(TilePosition _ n, _) fid -> (n, fid))
                    positions
                    [maxWindow, maxWindow - 1 ..]
                integrated = W.integrate s
             in W.Workspace t l $
                  W.differentiateWithFocus (W.focus s) $
                    inflateWithFakes 0 integrated positionToFakes
      app _ w = w

      inflateWithFakes :: Int -> [Window] -> [(Int, Window)] -> [Window]
      inflateWithFakes idx wins ((n,fake):fakes) | idx == n =
        fake : inflateWithFakes (idx + 1) wins fakes
      inflateWithFakes idx (w:wins) fakes =
        w : inflateWithFakes (idx + 1) wins fakes
      inflateWithFakes _ wins [] = wins
      inflateWithFakes _ [] fakes = map snd fakes

      sortIt = sortOn (\(TilePosition _ p, _) -> p)

  handleMessage h (fromMessage -> Just (ManageHole f)) =
    return $ Just $ f h
  handleMessage (Hole e l) a = do
    maybeNewLayout <- handleMessage l a
    return (Hole e <$> maybeNewLayout)