{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE NoFieldSelectors #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
{-# OPTIONS_GHC -fno-warn-type-defaults #-}

module Ui
  ( Ui (Ui),
    Block,
    lit,
    fill,
    pollUi,
    Env (..),
    Ui',
    layOutUi,
    renderUi,
    renderUi',
  )
where

import Control.Monad.Reader
import Control.Monad.State (evalStateT, get, modify)
import Data.Default
import Data.Map qualified as M
import Data.Maybe
import Data.Sensor qualified as S
import GHC.Generics (Generic)
import Graphics.X11 qualified as X
import Graphics.X11.Xft qualified as X
import Graphics.X11.Xrender qualified as X
import Pretty qualified as P

data Ui a = Ui [a] deriving (Eq, Functor, Foldable, Traversable, Show)

data Block a
  = Lit a
  | Fill
  deriving (Eq, Functor, Show)

lit :: (P.Pretty a) => a -> Block P.Doc
lit = Lit . P.pretty

fill :: Block a
fill = Fill

pollUi ::
  Ui (S.Sensor (S.SensorT IO) () (Block P.Doc)) ->
  S.Sensor (S.SensorT IO) () (Ui (Block P.Doc))
pollUi = sequence

layOutUi :: Env -> Ui (Block P.Doc) -> IO Ui'
layOutUi env (Ui bs) = layOut env (Ui' (concatMap go bs))
  where
    go (Lit doc) = go' doc
    go Fill =
      [ C
          { rect = def,
            fill = True,
            color = Nothing,
            string = ""
          }
      ]

    go' (P.Lit color string) =
      [ C
          { rect = def,
            fill = False,
            ..
          }
      ]
    go' (P.Col docs) =
      concatMap go' docs

layOut :: Env -> Ui' -> IO Ui'
layOut env@Env {..} (Ui' cs) = do
  cs' <- evalStateT (mapM pack cs) 0
  let rwidth = wwidth - sum (map (.rect.width) cs')
  pure (Ui' (expa rwidth cs'))
  where
    pack c = do
      rect <- io (extents env c)
      left <- get <* modify (+ rect.width)
      pure c {rect = rect {left = left}}

    expa rwidth (c@C {fill = True} : cs) =
      do
        c {rect = c.rect {width = c.rect.width + rwidth}}
        : map (\c -> c {rect = c.rect {left = c.rect.left + rwidth}}) cs
    expa rwidth (c : cs) = c : expa rwidth cs
    expa _ [] = []

extents :: Env -> C -> IO Rect
extents Env {..} (C {..}) = do
  glyphInfo <- X.xftTextExtents dpy fnt string
  pure
    ( Rect
        { top = 0,
          left = 0,
          width = X.xglyphinfo_xOff glyphInfo,
          height = X.xglyphinfo_height glyphInfo
        }
    )

data Env = Env
  { dpy :: X.Display,
    pixm :: X.Pixmap,
    gc :: X.GC,
    wwidth :: Int,
    wheight :: Int,
    vis :: X.Visual,
    cmap :: X.Colormap,
    fnt :: X.XftFont,
    drw :: X.XftDraw
  }

type Colors = M.Map (P.Intensity, P.Color) X.XftColor

renderUi :: Env -> Colors -> Ui' -> IO ()
renderUi Env {..} colors (Ui' cs) = do
  let bg = colors M.! (P.Dull, P.Black)
  X.xftDrawRect drw bg 0 0 wwidth wheight
  let h = maximum (map (.rect.height) cs)
  mapM_ (go h) cs
  where
    go h (C {..}) = do
      let fg = colors M.! fromMaybe (P.Dull, P.White) color
      liftIO (X.xftDrawString drw fg fnt rect.left h string)

renderUi' :: Env -> Colors -> Ui' -> Ui' -> IO ()
renderUi' env@Env {..} colors (Ui' cs') ui@(Ui' cs)
  | length cs' /= length cs = renderUi env colors ui
  | otherwise = do
      let h = maximum (map (.rect.height) cs)
          cs'' = catMaybes (zipWith (\c' c -> if c /= c' then Just c else Nothing) cs' cs)
      mapM_ (go h) cs''
  where
    go h (C {..}) = io do
      let bg = colors M.! (P.Dull, P.Black)
      let fg = colors M.! (fromMaybe (P.Dull, P.White) color)
      X.xftDrawRect drw bg rect.left 0 rect.width wheight
      X.xftDrawString drw fg fnt rect.left h string

data Ui' = Ui' [C] deriving (Show)

data C = C
  { rect :: Rect,
    fill :: Bool,
    color :: Maybe (P.Intensity, P.Color),
    string :: String
  }
  deriving (Show, Eq)

data Rect = Rect
  { top :: Int,
    left :: Int,
    width :: Int,
    height :: Int
  }
  deriving (Generic, Default, Show, Eq)

io :: (MonadIO m) => IO a -> m a
io = liftIO