{-# 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),
    lit,
    fill,
    sens,
    initUi,
    pollUi,
    Env (..),
    Ui',
    layOutUi,
    renderUi,
    renderUi',
  )
where

import Control.Concurrent.STM
import Control.Monad.Identity
import Control.Monad.Reader
import Control.Monad.State (evalStateT, get, modify)
import Data.Default
import Data.Dynamic
import Data.Map qualified as M
import Data.Maybe
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
import Sensor hiding (io)

data Ui f a = Ui [Block f a]

instance Eq (Ui Identity P.Doc) where
  Ui bs == Ui bs' = bs == bs'

data Block f a
  = Lit P.Doc
  | Fill
  | forall o. (Typeable o) => Sens (o -> a) (f o)

instance Eq (Block Identity P.Doc) where
  (Lit doc) == (Lit doc') = doc == doc'
  Fill == Fill = True
  Sens toOut (Identity x) == Sens toOut' (Identity x') = toOut x == toOut' x'
  _ == _ = False

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

fill :: Block f a
fill = Fill

sens :: (P.Pretty o, Typeable o) => f o -> Block f P.Doc
sens = Sens P.pretty

initUi ::
  Ui Sensor P.Doc ->
  SensorM (Ui TVar P.Doc)
initUi (Ui bs) = Ui <$> mapM go bs
  where
    go (Lit s) = pure (Lit s)
    go Fill = pure Fill
    go (Sens toOut s) = Sens toOut <$> poll s

pollUi ::
  Ui TVar P.Doc ->
  STM (Ui Identity P.Doc)
pollUi (Ui bs) = Ui <$> mapM go bs
  where
    go (Lit s) = pure (Lit s)
    go Fill = pure Fill
    go (Sens toOut vT) = Sens toOut . Identity <$> readTVar vT

layOutUi ::
  Env ->
  Ui Identity P.Doc ->
  IO Ui'
layOutUi env (Ui bs) = layOut env (Ui' (concatMap go bs))
  where
    go (Lit doc) = go' doc
    go (Sens toOut (runIdentity -> toOut -> 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