1 files changed, 56 insertions, 26 deletions

diff --git a/app/Ui.hs b/app/Ui.hs
index 2261f0a..92ef01a 100644
--- a/app/Ui.hs
+++ b/app/Ui.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE MultiWayIf #-}
 {-# LANGUAGE OverloadedRecordDot #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE StrictData #-}
@@ -12,8 +13,10 @@
 module Ui
   ( Ui (Ui),
     Block,
+    Flex (..),
     lit,
     fill,
+    litShrink,
     pollUi,
     Env (..),
     Ui',
@@ -48,41 +51,39 @@ data Ui a = Ui [a]
     )
 
 data Block a
-  = Lit a
-  | Fill
+  = Lit Flex a
   deriving (Eq, Functor, Show, Generic, NFData)
 
+data Flex = Flex
+  { canGrow :: Bool,
+    canShrink :: Bool
+  }
+  deriving (Eq, Show, Generic, NFData)
+
 lit :: (P.Pretty a) => a -> Block P.Doc
-lit = Lit . P.pretty
+lit = Lit (Flex False False) . P.pretty
+
+litShrink :: (P.Pretty a) => a -> Block P.Doc
+litShrink = Lit (Flex False True) . P.pretty
 
-fill :: Block a
-fill = Fill
+fill :: Block P.Doc
+fill = Lit (Flex True False) (P.pretty "")
 
 pollUi :: Ui (S.Sensor () (Block P.Doc)) -> S.Sensor () (Ui (Block P.Doc))
 pollUi (Ui sfs) = Ui <$> S.concatS sfs
 
 layOutUi :: Env -> Ui (Block P.Doc) -> IO Ui'
-layOutUi env (Ui bs) = layOut env (Ui' (concatMap go bs))
+layOutUi env (Ui bs) = shrinkText env =<< layOut env (Ui' (concatMap go bs))
   where
-    go (Lit doc) = go' doc
-    go Fill =
+    go (Lit flex (P.Lit color string)) =
       [ 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
+    go (Lit flex (P.Col docs)) =
+      -- TODO bug `P.Col` needs container support in `C`
+      concatMap (go . Lit flex) docs
 
 layOut :: Env -> Ui' -> IO Ui'
 layOut env@Env {..} (Ui' cs) = do
@@ -95,12 +96,41 @@ layOut env@Env {..} (Ui' cs) = do
       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 _ [] = []
+    expa 0 cs = cs
+    expa rwidth (c@C {flex = Flex False False} : cs) = c : expa rwidth cs
+    expa rwidth (c@C {flex = Flex {..}} : cs) =
+      if
+        | rwidth > 0 && canGrow ->
+            c {rect = c.rect {width = c.rect.width + rwidth}}
+              : map (\c -> c {rect = c.rect {left = c.rect.left + rwidth}}) cs
+        | rwidth < 0 && canShrink ->
+            c {rect = c.rect {width = c.rect.width + rwidth}}
+              : map (\c -> c {rect = c.rect {left = c.rect.left + rwidth}}) cs
+        | otherwise -> c : expa rwidth cs
+
+shrinkText :: Env -> Ui' -> IO Ui'
+shrinkText Env {..} (Ui' cs) = Ui' <$> mapM go cs
+  where
+    go C {..} = do
+      string' <- fit rect.width string
+      pure C {string = string', ..}
+
+    fit _ "" = pure ""
+    fit rwidth string = do
+      glyphInfo <- X.xftTextExtents dpy fnt string
+      let width = X.xglyphinfo_xOff glyphInfo
+      if width <= rwidth
+        then pure string
+        else fit' rwidth (init string)
+
+    fit' _ "" = pure ""
+    fit' rwidth string = do
+      glyphInfo <- X.xftTextExtents dpy fnt (string ++ "…")
+      let width = X.xglyphinfo_xOff glyphInfo
+      if width <= rwidth
+        then pure (string ++ "…")
+        else fit' rwidth (init string)
 
 extents :: Env -> C -> IO Rect
 extents Env {..} (C {..}) = do
@@ -158,7 +188,7 @@ data Ui' = Ui' [C] deriving (Show, Generic, NFData)
 
 data C = C
   { rect :: Rect,
-    fill :: Bool,
+    flex :: Flex,
     color :: Maybe (P.Intensity, P.Color),
     string :: String
   }