From ea2a725e9d5d758495b556631c3280de9d97fa0a Mon Sep 17 00:00:00 2001
From: Alexander Foremny <aforemny@posteo.de>
Date: Wed, 10 Apr 2024 14:05:08 +0200
Subject: init

---
 app/Ui.hs | 200 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 200 insertions(+)
 create mode 100644 app/Ui.hs

(limited to 'app/Ui.hs')

diff --git a/app/Ui.hs b/app/Ui.hs
new file mode 100644
index 0000000..fa1b38e
--- /dev/null
+++ b/app/Ui.hs
@@ -0,0 +1,200 @@
+{-# 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
-- 
cgit v1.2.3