From fdea2a59d330c866ce42526c4644952b038d073d Mon Sep 17 00:00:00 2001
From: Adrian Cochrane <adrian@openwork.nz>
Date: Fri, 2 Jun 2023 17:26:27 +1200
Subject: [PATCH] Insert Bidi characters into the tree handed to Balkon!

---
 Graphics/Layout.hs            |  2 +-
 Graphics/Layout/CSS.hs        | 23 +++++++----
 Graphics/Layout/Inline/CSS.hs | 77 +++++++++++++++++++----------------
 3 files changed, 58 insertions(+), 44 deletions(-)

diff --git a/Graphics/Layout.hs b/Graphics/Layout.hs
index 698b70e..fd17f7d 100644
--- a/Graphics/Layout.hs
+++ b/Graphics/Layout.hs
@@ -4,7 +4,7 @@
 -- Attempts to follow the CSS specs.
 -- See `boxLayout` for a main entrypoint,
 -- & `Graphics.Layout.CSS` to receive CSS input.
-module Graphics.Layout(LayoutItem(..),
+module Graphics.Layout(LayoutItem(..), UserData,
         layoutGetBox, layoutGetChilds, layoutGetInner,
         boxMinWidth, boxMaxWidth, boxNatWidth, boxWidth,
         boxNatHeight, boxMinHeight, boxMaxHeight, boxHeight,
diff --git a/Graphics/Layout/CSS.hs b/Graphics/Layout/CSS.hs
index 4fa90c8..b7fcd3b 100644
--- a/Graphics/Layout/CSS.hs
+++ b/Graphics/Layout/CSS.hs
@@ -1,4 +1,7 @@
 {-# LANGUAGE OverloadedStrings #-}
+-- These following language extensions are to aid a dependency injection into
+-- inline styling.
+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, FlexibleContexts #-}
 -- | Parses & desugars CSS properties to general CatTrap datastructures.
 module Graphics.Layout.CSS(CSSBox(..), BoxSizing(..), Display(..),
         finalizeCSS, finalizeCSS') where
@@ -20,6 +23,9 @@ import Graphics.Layout.Inline.CSS
 import Data.Char (isSpace)
 import Graphics.Layout.CSS.Parse
 
+instance (PropertyParser x, Zero m, Zero n) => Default (UserData m n x) where
+    def = ((placeholderFont, 0), zero, temp)
+
 -- | Desugar parsed CSS into more generic layout parameters.
 finalizeCSS :: PropertyParser x => Font' -> Font' -> StyleTree (CSSBox x) ->
         LayoutItem Length Length x
@@ -86,16 +92,15 @@ finalizeChilds root parent style' childs@(child:childs')
     flattenTree0 childs = RootBox $ Box (map (flattenTree parent) $
         enumerate childs) $ flip applyFontInline parent $ txtOpts style'
     flattenTree p (i, StyleTree { children = child@(_:_), style = self }) =
-        InlineBox ((f, i), finalizeBox self f, inner self)
-            (Box (map (flattenTree f) $ enumerate child)
-                $ flip applyFontInline f $ txtOpts self)
-            defaultBoxOptions -- Fill in during layout.
-          where f = pattern2font (font self) (font' self) p root
+        buildInline f i self $ map (flattenTree f) $ enumerate child
+      where f = pattern2font (font self) (font' self) p root
     flattenTree f (i,StyleTree {style=self@CSSBox {inlineStyles=CSSInline txt _ _}})
-        = InlineBox ((f, i), finalizeBox self f, inner self)
-            (Box [TextSequence ((f, 0), zero, inherit $ inner self) txt] $
-                flip applyFontInline f $ txtOpts self)
-            defaultBoxOptions -- Fill in during layout.
+        = buildInline f i self [TextSequence ((f,0),zero,inherit $ inner self) txt]
+    buildInline f i self childs =
+        InlineBox ((f, i), finalizeBox self f, inner self)
+                (Box childs' $ flip applyFontInline f $ txtOpts self)
+                defaultBoxOptions -- Fill in during layout.
+      where childs' = applyBidi (inlineStyles self) childs
     finalizeParagraph (RootBox (Box [TextSequence _ txt] _))
         | Txt.all isSpace txt = Nothing -- Discard isolated whitespace.
     finalizeParagraph tree =
diff --git a/Graphics/Layout/Inline/CSS.hs b/Graphics/Layout/Inline/CSS.hs
index 7abc0ce..7d3bdc9 100644
--- a/Graphics/Layout/Inline/CSS.hs
+++ b/Graphics/Layout/Inline/CSS.hs
@@ -1,11 +1,12 @@
 {-# LANGUAGE OverloadedStrings, ViewPatterns #-}
 -- | Infrastructure for parsing & desugaring text related CSS properties.
-module Graphics.Layout.Inline.CSS(CSSInline(..), applyFontInline, applyBidi) where
+module Graphics.Layout.Inline.CSS(
+    CSSInline(..), Default(..), applyFontInline, applyBidi) where
 
 import Data.CSS.Syntax.Tokens (Token(..))
 import Stylist (PropertyParser(..))
 import qualified Data.Text as Txt
-import Data.Text (Text, cons, snoc)
+import Data.Text (Text)
 import Data.Text.ParagraphLayout.Rich
 import Data.Text.Glyphize (Direction(..))
 
@@ -67,37 +68,45 @@ applyFontInline opts font = opts {
     textLineHeight = Absolute $ toEnum $ fromEnum $ lineheight font * hbUnit
   }
 -- | Apply Bidi chars around the inline text. FIXME: Handle the tree!
-applyBidi :: CSSInline -> Text
-applyBidi (CSSInline txt _ BdNormal) = txt
-applyBidi (CSSInline txt (textDirection -> DirLTR) BdEmbed) =
-    chLREmbed `cons` txt `snoc` chPopDir
-applyBidi (CSSInline txt (textDirection -> DirRTL) BdEmbed) =
-    chRLEmbed `cons` txt `snoc` chPopDir
-applyBidi (CSSInline txt (textDirection -> DirLTR) BdIsolate) =
-    chLRIsolate `cons` txt `snoc` chPopDirIsolate
-applyBidi (CSSInline txt (textDirection -> DirRTL) BdIsolate) =
-    chRLIsolate `cons` txt `snoc` chPopDirIsolate
-applyBidi (CSSInline txt (textDirection -> DirLTR) BdOverride) =
-    chLROverride `cons` txt `snoc` chPopDir
-applyBidi (CSSInline txt (textDirection -> DirRTL) BdOverride) =
-    chRLOverride `cons` txt `snoc` chPopDir
-applyBidi (CSSInline txt (textDirection -> DirLTR) BdIsolateOverride) =
-    ch1stStrongIsolate `cons` chLROverride `cons` txt
-        `snoc` chPopDir `snoc` chPopDirIsolate
-applyBidi (CSSInline txt (textDirection -> DirRTL) BdIsolateOverride) =
-    ch1stStrongIsolate `cons` chRLOverride `cons` txt
-        `snoc` chPopDir `snoc` chPopDirIsolate
-applyBidi (CSSInline txt _ BdPlainText) =
-    ch1stStrongIsolate `cons` txt `snoc` chPopDirIsolate
-applyBidi (CSSInline txt (textDirection -> dir) _) =
+applyBidi :: Default d => CSSInline -> [InnerNode Text d] -> [InnerNode Text d]
+applyBidi (CSSInline _ _ BdNormal) txt = txt
+applyBidi (CSSInline _ (textDirection -> DirLTR) BdEmbed) txt =
+    chLREmbed:txt+:chPopDir
+applyBidi (CSSInline _ (textDirection -> DirRTL) BdEmbed) txt =
+    chRLEmbed:txt+:chPopDir
+applyBidi (CSSInline _ (textDirection -> DirLTR) BdIsolate) txt =
+    chLRIsolate:txt+:chPopDirIsolate
+applyBidi (CSSInline _ (textDirection -> DirRTL) BdIsolate) txt =
+    chRLIsolate:txt+:chPopDirIsolate
+applyBidi (CSSInline _ (textDirection -> DirLTR) BdOverride) txt =
+    chLROverride:txt+:chPopDir
+applyBidi (CSSInline _ (textDirection -> DirRTL) BdOverride) txt =
+    chRLOverride:txt+:chPopDir
+applyBidi (CSSInline _ (textDirection -> DirLTR) BdIsolateOverride) txt =
+    ch1stStrongIsolate:chLROverride:txt+:chPopDir+:chPopDirIsolate
+applyBidi (CSSInline _ (textDirection -> DirRTL) BdIsolateOverride) txt =
+    ch1stStrongIsolate:chRLOverride:txt+:chPopDir+:chPopDirIsolate
+applyBidi (CSSInline _ _ BdPlainText) txt =
+    ch1stStrongIsolate:txt+:chPopDirIsolate
+applyBidi (CSSInline _ (textDirection -> dir) _) txt =
     trace ("Unexpected direction! " ++ show dir) txt
 
-chLREmbed = '\x202A'
-chRLEmbed = '\x202B'
-chLROverride = '\x202D'
-chRLOverride = '\x202E'
-chPopDir = '\x202C'
-chLRIsolate = '\x2066'
-chRLIsolate = '\x2067'
-ch1stStrongIsolate = '\x2068'
-chPopDirIsolate = '\x2069'
+a +: b = a ++ [b]
+
+chLREmbed, chRLEmbed, chLROverride, chRLOverride, chPopDir,
+    chLRIsolate, chRLIsolate, ch1stStrongIsolate, chPopDirIsolate :: Default a =>
+        InnerNode Text a
+chLREmbed = leaf '\x202A'
+chRLEmbed = leaf '\x202B'
+chLROverride = leaf '\x202D'
+chRLOverride = leaf '\x202E'
+chPopDir = leaf '\x202C'
+chLRIsolate = leaf '\x2066'
+chRLIsolate = leaf '\x2067'
+ch1stStrongIsolate = leaf '\x2068'
+chPopDirIsolate = leaf '\x2069'
+
+leaf ch = TextSequence def $ Txt.singleton ch
+
+class Default a where
+    def :: a
-- 
2.30.2