From d1b417ef572d40cdb8dd7ad5fd83d9b62fdc48df Mon Sep 17 00:00:00 2001
From: Jaro <jaro@argonaut-constellation.org>
Date: Sat, 25 Feb 2023 01:34:34 +0100
Subject: [PATCH] Link to Span using a generic wrapper.

---
 src/Data/Text/ParagraphLayout/Plain.hs    | 45 +++++++++++++----------
 src/Data/Text/ParagraphLayout/Run.hs      |  2 -
 test/Data/Text/ParagraphLayout/RunSpec.hs |  3 --
 3 files changed, 26 insertions(+), 24 deletions(-)

diff --git a/src/Data/Text/ParagraphLayout/Plain.hs b/src/Data/Text/ParagraphLayout/Plain.hs
index 72d422b..bee2bcf 100644
--- a/src/Data/Text/ParagraphLayout/Plain.hs
+++ b/src/Data/Text/ParagraphLayout/Plain.hs
@@ -87,6 +87,12 @@ data ParagraphLayout = ParagraphLayout
 data SpanLayout = SpanLayout [Fragment]
     deriving (Eq, Read, Show)
 
+-- | Wrapper for temporarily mapping the relationship to a `Span`.
+data WithSpan a = WithSpan RS.ResolvedSpan a
+
+instance Functor WithSpan where
+    fmap f (WithSpan s a) = WithSpan s (f a)
+
 spanRects :: SpanLayout -> [Rect Int32]
 spanRects (SpanLayout frags) = map fragmentRect frags
 
@@ -131,12 +137,15 @@ addSpansH currentX rss = mapAccumL addSpanH currentX rss
 -- and return the final x_offset for continuation.
 addSpanH :: Int32 -> RS.ResolvedSpan -> (Int32, SpanLayout)
 addSpanH currentX rs = (nextX, SpanLayout frags)
-    where (nextX, frags) = mapAccumL addRunH currentX $ spanToRuns rs
+    where (nextX, frags) = mapAccumL addRunH currentX $ spanToRunsWrapped rs
+
+spanToRunsWrapped :: RS.ResolvedSpan -> [WithSpan Run]
+spanToRunsWrapped s = map (WithSpan s) (spanToRuns s)
 
 -- | Calculate layout for the given run,
 -- place the generated fragment horizontally at the given x_offset,
 -- and return the final x_offset for continuation.
-addRunH :: Int32 -> Run -> (Int32, Fragment)
+addRunH :: Int32 -> WithSpan Run -> (Int32, Fragment)
 addRunH currentX run = (nextX, nextFrag)
     where
         frag = layoutRun run
@@ -145,14 +154,13 @@ addRunH currentX run = (nextX, nextFrag)
         nextFrag = frag { fragmentRect = nextRect }
         nextRect = rect { x_origin = currentX }
 
--- | Calculate layout for the given run independently of its position.
-layoutRun :: Run -> Fragment
-layoutRun run = Fragment rect (penX, penY) glyphs
+layoutRun :: WithSpan Run -> Fragment
+layoutRun (WithSpan rs run) = Fragment rect (penX, penY) glyphs
     where
         rect = containGlyphsH lineHeight $ map snd $ glyphs
         penX = 0 -- for horizontal text
         penY = descent + leading `div` 2
-        glyphs = shapeRun run
+        glyphs = shapeRun (WithSpan rs run)
         lineHeight = case RS.spanLineHeight rs of
             Normal -> normalLineHeight
             Absolute h -> h
@@ -163,10 +171,10 @@ layoutRun run = Fragment rect (penX, penY) glyphs
         extents = fontExtentsForDir font dir
         font = RS.spanFont rs
         dir = runDirection run
-        rs = runOriginalSpan run
 
-shapeRun :: Run -> [(GlyphInfo, GlyphPos)]
-shapeRun run = shape font buffer features
+-- | Calculate layout for the given run independently of its position.
+shapeRun :: WithSpan Run -> [(GlyphInfo, GlyphPos)]
+shapeRun (WithSpan rs run) = shape font buffer features
     where
         font = RS.spanFont rs
         -- TODO: Set beginsText / endsText.
@@ -178,18 +186,17 @@ shapeRun run = shape font buffer features
             , language = Just $ RS.spanLanguage rs
             }
         features = []
-        rs = runOriginalSpan run
 
 resolveSpans :: Paragraph -> [RS.ResolvedSpan]
-resolveSpans (Paragraph arr off spans opts) = map resolve $ zip spans texts
-    where
-        resolve (s, t) = RS.ResolvedSpan
-            { RS.spanText = t
-            , RS.spanFont = paragraphFont opts
-            , RS.spanLineHeight = paragraphLineHeight opts
-            , RS.spanLanguage = spanLanguage s
-            }
-        texts = cuts arr off spans
+resolveSpans (Paragraph arr off spans opts) = do
+    let texts = cuts arr off spans
+    (s, t) <- zip spans texts
+    return RS.ResolvedSpan
+        { RS.spanText = t
+        , RS.spanFont = paragraphFont opts
+        , RS.spanLineHeight = paragraphLineHeight opts
+        , RS.spanLanguage = spanLanguage s
+        }
 
 -- | Produce a list of `Text`s, defined by an initial offset and a list of
 -- consecutive `Span`s, out of the underlying `Array`.
diff --git a/src/Data/Text/ParagraphLayout/Run.hs b/src/Data/Text/ParagraphLayout/Run.hs
index 736b449..38ccd99 100644
--- a/src/Data/Text/ParagraphLayout/Run.hs
+++ b/src/Data/Text/ParagraphLayout/Run.hs
@@ -20,7 +20,6 @@ data Run = Run
     { runText :: Text
     , runDirection :: Maybe Direction
     , runScript :: Maybe ScriptCode
-    , runOriginalSpan :: ResolvedSpan
     }
     deriving (Eq, Show)
 
@@ -56,7 +55,6 @@ spanToRuns s = map run $ protoRuns zipper
             { runText = preceding z
             , runDirection = d
             , runScript = Just sc
-            , runOriginalSpan = s
             }
 
 protoRuns :: Zipper -> [ProtoRun]
diff --git a/test/Data/Text/ParagraphLayout/RunSpec.hs b/test/Data/Text/ParagraphLayout/RunSpec.hs
index 6329ae1..dd7d361 100644
--- a/test/Data/Text/ParagraphLayout/RunSpec.hs
+++ b/test/Data/Text/ParagraphLayout/RunSpec.hs
@@ -22,7 +22,6 @@ spec = do
                     { runText = spanText inputSpan
                     , runDirection = Just DirLTR
                     , runScript = Just "Latn"
-                    , runOriginalSpan = inputSpan
                     }
                 ]
         it "handles Serbian with mixed script" $ \font -> do
@@ -34,12 +33,10 @@ spec = do
                     { runText = pack "Vikipedija ("
                     , runDirection = Just DirLTR
                     , runScript = Just "Latn"
-                    , runOriginalSpan = inputSpan
                     }
                 , Run
                     { runText = pack "Википедија)"
                     , runDirection = Just DirLTR
                     , runScript = Just "Cyrl"
-                    , runOriginalSpan = inputSpan
                     }
                 ]
-- 
2.30.2