From 28d5a502818102ee72dc172d6e990f74532df2ef Mon Sep 17 00:00:00 2001 From: Jaro Date: Sat, 6 May 2023 02:45:40 +0200 Subject: [PATCH] Use ResolvedBox when flattening trees. --- balkon.cabal | 1 + .../Text/ParagraphLayout/Internal/Tree.hs | 32 ++-- .../Text/ParagraphLayout/Internal/TreeSpec.hs | 155 ++++++++++++++++++ 3 files changed, 175 insertions(+), 13 deletions(-) create mode 100644 test/Data/Text/ParagraphLayout/Internal/TreeSpec.hs diff --git a/balkon.cabal b/balkon.cabal index e00d01f..72d5e69 100644 --- a/balkon.cabal +++ b/balkon.cabal @@ -184,6 +184,7 @@ test-suite balkon-test Data.Text.ParagraphLayout.Internal.LinePaginationSpec, Data.Text.ParagraphLayout.Internal.RunSpec, Data.Text.ParagraphLayout.Internal.TextContainerSpec, + Data.Text.ParagraphLayout.Internal.TreeSpec, Data.Text.ParagraphLayout.Internal.ZipperSpec, Data.Text.ParagraphLayout.Plain.ParagraphData, Data.Text.ParagraphLayout.PlainSpec, diff --git a/src/Data/Text/ParagraphLayout/Internal/Tree.hs b/src/Data/Text/ParagraphLayout/Internal/Tree.hs index 2ea1d28..085295a 100644 --- a/src/Data/Text/ParagraphLayout/Internal/Tree.hs +++ b/src/Data/Text/ParagraphLayout/Internal/Tree.hs @@ -12,6 +12,7 @@ module Data.Text.ParagraphLayout.Internal.Tree where import Data.Text.ParagraphLayout.Internal.BoxOptions +import Data.Text.ParagraphLayout.Internal.ResolvedBox import Data.Text.ParagraphLayout.Internal.TextOptions -- | Root of the paragraph tree. @@ -54,8 +55,8 @@ data Box d = Box -- ^ Style options to apply to text sequences directly contained -- by this box. --- TODO: we need a way to test box equality, maybe add indexes? -type BoxPath d = [(d, BoxOptions)] + +type BoxPath d = [ResolvedBox d] -- | Representation of a leaf node of the tree after flattening. data Leaf d = TextLeaf @@ -75,14 +76,19 @@ data Leaf d = TextLeaf -- | Convert the tree to a flat list of its leaf nodes (text sequences). flatten :: RootNode d -> [Leaf d] -flatten (RootBox (Box ns textOpts)) = flattenNodes [] textOpts ns - -flattenNodes :: BoxPath d -> TextOptions -> [InnerNode d] -> [Leaf d] -flattenNodes _ _ [] = [] -flattenNodes path textOpts (n : ns) = - flattenNode path textOpts n ++ flattenNodes path textOpts ns - -flattenNode :: BoxPath d -> TextOptions -> InnerNode d -> [Leaf d] -flattenNode path textOpts (TextSequence d len) = [TextLeaf d len textOpts path] -flattenNode path _ (InlineBox d (Box ns textOpts) boxOpts) = - flattenNodes ((d, boxOpts) : path) textOpts ns +flatten (RootBox (Box ns textOpts)) = snd $ flattenNodes 0 [] textOpts ns + +flattenNodes :: Int -> BoxPath d -> TextOptions -> [InnerNode d] -> + (Int, [Leaf d]) +flattenNodes idx _ _ [] = (idx, []) +flattenNodes idx path textOpts (n : ns) = (idx'', flat1 ++ flat2) + where + (idx', flat1) = flattenNode idx path textOpts n + (idx'', flat2) = flattenNodes idx' path textOpts ns + +flattenNode :: Int -> BoxPath d -> TextOptions -> InnerNode d -> + (Int, [Leaf d]) +flattenNode idx path textOpts (TextSequence d len) = + (idx, [TextLeaf d len textOpts path]) +flattenNode idx path _ (InlineBox d (Box ns textOpts) boxOpts) = + flattenNodes (idx + 1) (ResolvedBox d idx boxOpts : path) textOpts ns diff --git a/test/Data/Text/ParagraphLayout/Internal/TreeSpec.hs b/test/Data/Text/ParagraphLayout/Internal/TreeSpec.hs new file mode 100644 index 0000000..f01305e --- /dev/null +++ b/test/Data/Text/ParagraphLayout/Internal/TreeSpec.hs @@ -0,0 +1,155 @@ +module Data.Text.ParagraphLayout.Internal.TreeSpec (spec) where + +import Test.Hspec +import Data.Text.ParagraphLayout.Internal.BoxOptions +import Data.Text.ParagraphLayout.Internal.ResolvedBox +import Data.Text.ParagraphLayout.Internal.TextOptions +import Data.Text.ParagraphLayout.Internal.Tree + +complexTree :: RootNode String +complexTree = RootBox $ Box + [ TextSequence "a" 1 + , InlineBox + "box1" + (Box + [ TextSequence "b" 1 + , TextSequence "c" 1 + , InlineBox + "box2" + (Box + [ TextSequence "d" 1 + , TextSequence "e" 1 + ] + defaultTextOptions + ) + defaultBoxOptions + , TextSequence "f" 1 + , InlineBox + "box3" + (Box + [ TextSequence "g" 1 + , InlineBox + "box4" + (Box + [ TextSequence "h" 1 + ] + defaultTextOptions + ) + defaultBoxOptions + , TextSequence "i" 1 + ] + defaultTextOptions + ) + defaultBoxOptions + ] + defaultTextOptions + ) + defaultBoxOptions + , InlineBox + "box5" + (Box + [ InlineBox + "box6" + (Box + [ TextSequence "j" 1 + , TextSequence "k" 1 + ] + defaultTextOptions + ) + defaultBoxOptions + , InlineBox + "box7" + (Box + [ InlineBox + "box8" + (Box + [ TextSequence "l" 1 + ] + defaultTextOptions + ) + defaultBoxOptions + ] + defaultTextOptions + ) + defaultBoxOptions + , TextSequence "m" 1 + ] + defaultTextOptions + ) + defaultBoxOptions + ] + defaultTextOptions + +leafData :: Leaf d -> d +leafData (TextLeaf d _ _ _) = d + +leafPath :: Leaf d -> [ResolvedBox d] +leafPath (TextLeaf _ _ _ path) = path + +leafDepth :: Leaf d -> Int +leafDepth = length . leafPath + +leafPathData :: Leaf d -> [d] +leafPathData = map boxUserData . leafPath + +leafPathIndexes :: Leaf d -> [Int] +leafPathIndexes = map boxIndex . leafPath + +spec :: Spec +spec = do + + describe "flatten" $ do + let leaves = flatten complexTree + + it "should have one leaf per text sequence" $ + length leaves `shouldBe` 13 + + it "leaves should have expected data" $ do + map leafData leaves `shouldBe` + map (: []) ['a' .. 'm'] + + it "leaves should have expected depths" $ do + map leafDepth leaves `shouldBe` + [0, 1, 1, 2, 2, 1, 2, 3, 2, 2, 2, 3, 1] + + it "leaves should have expected ancestor data" $ do + map leafPathData leaves `shouldBe` + [ [] + , ["box1"] + , ["box1"] + , ["box2", "box1"] + , ["box2", "box1"] + , ["box1"] + , ["box3", "box1"] + , ["box4", "box3", "box1"] + , ["box3", "box1"] + , ["box6", "box5"] + , ["box6", "box5"] + , ["box8", "box7", "box5"] + , ["box5"] + ] + + it "leaves should have expected ancestor indexes" $ do + map leafPathIndexes leaves `shouldBe` + [ [] + , [0] + , [0] + , [1, 0] + , [1, 0] + , [0] + , [2, 0] + , [3, 2, 0] + , [2, 0] + , [5, 4] + , [5, 4] + , [7, 6, 4] + , [4] + ] + + it "leaves 'c' and 'f' should have the same parent" $ + leafPath (leaves !! 2) !! 0 == + leafPath (leaves !! 5) !! 0 `shouldBe` True + + it "leaves 'e' and 'i' should have a different parent" $ + leafPath (leaves !! 4) !! 0 == + leafPath (leaves !! 8) !! 0 `shouldBe` False -- 2.30.2