{-# 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 Trace "Hole:"
  forM_ (Map.toList mp) $ \(wid, poses) ->
    logs Trace "  wid[%s] - [%s]" wid $
      intercalate
        ","
        ( map (\(TilePosition _ n, w) -> show w ++ "@" ++ show n) poses
        )

-- toggleHole :: ManageHole
-- toggleHole = ManageHole $ \(Hole e l) -> Hole (not e) l

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 integrated = W.integrate s
           in W.Workspace t l $
                W.differentiateWithFocus (W.focus s) $
                  reverse $
                    addr integrated $
                      foldl
                        ( \((idx, pos, fakeid), ret) w ->
                            case pos of
                              ((TilePosition _ n, win) : tpos)
                                | n == idx && maybe True (`notElem` integrated) win ->
                                  ((idx + 1, tpos, fakeid - 1), w : fakeid : ret)
                              _ -> ((idx + 1, pos, fakeid), w : ret)
                        )
                        ((0, positions, 10000000), [])
                        integrated
      app _ w = w

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

      addr integrated ((idx, pos, fakeid), ret) =
        case pos of
          ((TilePosition _ n, win) : _) | n == idx && maybe True (`notElem` integrated) win -> fakeid : ret
          _ -> ret

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