From 03d36342529a318aa40fa9da94e8555e2f2017d5 Mon Sep 17 00:00:00 2001
From: Jaro <jaro@argonaut-constellation.org>
Date: Tue, 2 May 2023 06:59:12 +0200
Subject: [PATCH] Implement Rich pagination.

---
 src/Data/Text/ParagraphLayout/Internal/Paginable.hs    |  9 +++++++++
 .../Text/ParagraphLayout/Internal/ParagraphLine.hs     | 10 ++++++++++
 .../ParagraphLayout/Internal/Rich/ParagraphLayout.hs   |  4 ++++
 3 files changed, 23 insertions(+)

diff --git a/src/Data/Text/ParagraphLayout/Internal/Paginable.hs b/src/Data/Text/ParagraphLayout/Internal/Paginable.hs
index 7131a9d..35731bb 100644
--- a/src/Data/Text/ParagraphLayout/Internal/Paginable.hs
+++ b/src/Data/Text/ParagraphLayout/Internal/Paginable.hs
@@ -12,6 +12,8 @@ import Data.Text.ParagraphLayout.Internal.LinePagination
 import Data.Text.ParagraphLayout.Internal.ParagraphLine
 import qualified Data.Text.ParagraphLayout.Internal.Plain.ParagraphLayout
     as Plain
+import qualified Data.Text.ParagraphLayout.Internal.Rich.ParagraphLayout
+    as Rich
 
 -- | Defines options for breaking a layout into pages.
 data PageOptions = PageOptions
@@ -81,6 +83,13 @@ instance Paginable (Plain.ParagraphLayout d) where
         (c, p, Nothing) -> (c, mergeLines p, Nothing)
         (c, p, Just rest) -> (c, mergeLines p, Just (mergeLines rest))
 
+-- | Implementation of paginating a rich text paragraph layout.
+-- Breaks the layout on page boundaries and automatically adjusts coordinates.
+instance Paginable (Rich.ParagraphLayout d) where
+    paginate opts pl = case paginate opts (cutLines pl) of
+        (c, p, Nothing) -> (c, mergeLines p, Nothing)
+        (c, p, Just rest) -> (c, mergeLines p, Just (mergeLines rest))
+
 -- | Perform page breaking on the entire input, returning a list of pages.
 paginateAll :: Paginable a => PageOptions -> a -> [(PageContinuity, a)]
 paginateAll opts pl = case paginate opts pl of
diff --git a/src/Data/Text/ParagraphLayout/Internal/ParagraphLine.hs b/src/Data/Text/ParagraphLayout/Internal/ParagraphLine.hs
index d662fae..656f988 100644
--- a/src/Data/Text/ParagraphLayout/Internal/ParagraphLine.hs
+++ b/src/Data/Text/ParagraphLayout/Internal/ParagraphLine.hs
@@ -10,6 +10,7 @@ import qualified Data.List.NonEmpty as NonEmpty
 
 import Data.Text.ParagraphLayout.Internal.Fragment
 import qualified Data.Text.ParagraphLayout.Internal.Plain.ParagraphLayout as P
+import qualified Data.Text.ParagraphLayout.Internal.Rich.ParagraphLayout as R
 import Data.Text.ParagraphLayout.Internal.Rect
 
 class GenericLayout pl where
@@ -45,6 +46,15 @@ instance GenericLayout (P.ParagraphLayout d) where
     shiftFragments dy = P.mapFragments (shiftFragment dy)
     appendFragments = P.appendFragments
 
+instance GenericLayout (R.ParagraphLayout d) where
+    empty = R.emptyParagraphLayout
+    rect = R.paragraphRect
+    topDistance pl = topFragmentOrigin $ R.paragraphFragments pl
+    lineNumbers pl = uniqueFragmentLines $ R.paragraphFragments pl
+    limitFragments n = R.filterFragments (fragmentIsOnLine n)
+    shiftFragments dy = R.mapFragments (shiftFragment dy)
+    appendFragments = R.appendFragments
+
 -- | Split the given `ParagraphLayout` into single-line layouts.
 cutLines :: GenericLayout pl => pl -> [pl]
 cutLines pl = map (\ n -> cutLine n pl) (lineNumbers pl)
diff --git a/src/Data/Text/ParagraphLayout/Internal/Rich/ParagraphLayout.hs b/src/Data/Text/ParagraphLayout/Internal/Rich/ParagraphLayout.hs
index f812bf0..d2e5be1 100644
--- a/src/Data/Text/ParagraphLayout/Internal/Rich/ParagraphLayout.hs
+++ b/src/Data/Text/ParagraphLayout/Internal/Rich/ParagraphLayout.hs
@@ -14,6 +14,7 @@ where
 import Data.Int (Int32)
 
 import Data.Text.ParagraphLayout.Internal.Fragment
+import Data.Text.ParagraphLayout.Internal.LinePagination
 import Data.Text.ParagraphLayout.Internal.ParagraphExtents
 import Data.Text.ParagraphLayout.Internal.Rect
 
@@ -28,6 +29,9 @@ data ParagraphLayout d = ParagraphLayout
     }
     deriving (Eq, Read, Show)
 
+instance Line (ParagraphLayout d) where
+    lineHeight pl = height $ paragraphRect pl
+
 -- | Wrap the given `Fragment`s and compute their containing rectangle.
 paragraphLayout :: [Fragment d] -> ParagraphLayout d
 paragraphLayout frags = ParagraphLayout pRect frags
-- 
2.30.2