From 2d69d190193e4edf1a137fc615b8eb0c895f1824 Mon Sep 17 00:00:00 2001 From: Jaro Date: Thu, 6 Apr 2023 14:26:30 +0200 Subject: [PATCH] Mark some lists as explicitly non-empty. --- .../Text/ParagraphLayout/Internal/Plain.hs | 42 ++++++++----- .../ParagraphLayout/Internal/TextContainer.hs | 62 ++++++++++++------- .../Internal/TextContainerSpec.hs | 40 ++++++------ 3 files changed, 86 insertions(+), 58 deletions(-) diff --git a/src/Data/Text/ParagraphLayout/Internal/Plain.hs b/src/Data/Text/ParagraphLayout/Internal/Plain.hs index 1848878..f0ec311 100644 --- a/src/Data/Text/ParagraphLayout/Internal/Plain.hs +++ b/src/Data/Text/ParagraphLayout/Internal/Plain.hs @@ -10,7 +10,7 @@ where import Control.Applicative (ZipList(ZipList), getZipList) import Data.Int (Int32) import Data.List (mapAccumL) -import Data.List.NonEmpty (NonEmpty((:|))) +import Data.List.NonEmpty (NonEmpty((:|)), nonEmpty, (<|)) import qualified Data.List.NonEmpty as NonEmpty import Data.Text.Foreign (lengthWord8) import Data.Text.Glyphize @@ -48,7 +48,10 @@ layoutPlain p@(Paragraph _ _ _ opts) = paragraphLayout sls where sls = map SpanLayout fragsBySpan fragsBySpan = take (length spans) $ RS.splitBySpanIndex frags - frags = layoutAndAlignLines maxWidth $ spansToRunsWrapped spans + frags = case nonEmpty wrappedRuns of + Just xs -> layoutAndAlignLines maxWidth xs + Nothing -> [] + wrappedRuns = spansToRunsWrapped spans maxWidth = paragraphMaxWidth opts spans = resolveSpans p @@ -66,12 +69,12 @@ spanToRunsWrapped s = map (WithSpan s) (spanToRuns s) -- necessary to fit within the requested line width. -- -- The output is a flat list of fragments positioned in both dimensions. -layoutAndAlignLines :: Int32 -> [WithSpan Run] -> [WithSpan Fragment] +layoutAndAlignLines :: Int32 -> NonEmpty (WithSpan Run) -> [WithSpan Fragment] layoutAndAlignLines maxWidth runs = frags where frags = concat fragsInLines (_, fragsInLines) = mapAccumL positionLineH originY canonicalLines - canonicalLines = map canonicalOrder logicalLines + canonicalLines = fmap canonicalOrder logicalLines logicalLines = layoutLines maxWidth runs originY = paragraphOriginY @@ -95,14 +98,13 @@ canonicalOrder pfs@((WithSpan _ headPF):_) = case PF.direction headPF of -- -- The output is a two-dimensional list of fragments positioned along the -- horizontal axis. -layoutLines :: Int32 -> [WithSpan Run] -> [[WithSpan PF.ProtoFragment]] -layoutLines maxWidth runs - | null rest +layoutLines :: + Int32 -> NonEmpty (WithSpan Run) -> NonEmpty [WithSpan PF.ProtoFragment] +layoutLines maxWidth runs = case nonEmpty rest of -- Everything fits. We are done. - = fitting : [] - | otherwise + Nothing -> NonEmpty.singleton fitting -- Something fits, the rest goes on the next line. - = fitting : layoutLines maxWidth rest + Just rest' -> fitting <| layoutLines maxWidth rest' where (fitting, rest) = layoutAndWrapRunsH maxWidth runs @@ -152,13 +154,13 @@ positionFragmentH originY originX (WithSpan rs pf) = (nextX, WithSpan rs frag) -- | Calculate layout for multiple horizontal runs, breaking them as necessary -- to fit as much content as possible without exceeding the maximum line width, -- and return the remaining runs to be placed on other lines. -layoutAndWrapRunsH :: Int32 -> [WithSpan Run] -> +layoutAndWrapRunsH :: Int32 -> NonEmpty (WithSpan Run) -> ([WithSpan PF.ProtoFragment], [WithSpan Run]) layoutAndWrapRunsH maxWidth runs = NonEmpty.head $ validLayouts where validLayouts = dropWhile1 tooLong layouts tooLong (pfs, _) = totalAdvances pfs > maxWidth - layouts = NonEmpty.map layoutFst splits + layouts = fmap layoutFst splits layoutFst (runs1, runs2) = (layoutRunsH runs1, runs2) -- TODO: Consider optimising. -- We do not need to look for soft breaks further than the @@ -176,8 +178,8 @@ layoutAndWrapRunsH maxWidth runs = NonEmpty.head $ validLayouts -- -- If there is no hard line break in the input, the first output list will -- contain the whole input, and the second output list will be empty. -hardSplit :: [WithSpan Run] -> ([WithSpan Run], [WithSpan Run]) -hardSplit runs = trimFst $ NonEmpty.last $ splits +hardSplit :: NonEmpty (WithSpan Run) -> ([WithSpan Run], [WithSpan Run]) +hardSplit runs = allowFstEmpty $ trimFst $ NonEmpty.last $ splits where trimFst (runs1, runs2) = (trim runs1, runs2) trim @@ -187,7 +189,7 @@ hardSplit runs = trimFst $ NonEmpty.last $ splits -- TODO: Consider optimising. -- We do not need to look for any line breaks further than the -- shortest hard break. - splits = noSplit :| hSplits + splits = noSplit :| map allowSndEmpty hSplits noSplit = (runs, []) hSplits = -- from longest to shortest splitTextsBy (map fst . filter isHard . runLineBreaks) runs @@ -205,8 +207,8 @@ hardSplit runs = trimFst $ NonEmpty.last $ splits -- The results in the form (prefix, suffix) will be ordered so that items -- closer to the start of the list are preferred for line breaking, but without -- considering overflows. -softSplits :: [WithSpan Run] -> [([WithSpan Run], [WithSpan Run])] -softSplits runs = map trimFst splits +softSplits :: NonEmpty (WithSpan Run) -> [([WithSpan Run], [WithSpan Run])] +softSplits runs = map (allowSndEmpty . trimFst) splits where trimFst (runs1, runs2) = (trim runs1, runs2) trim = trimTextsStart isStartSpace . trimTextsEnd isEndSpace @@ -217,6 +219,12 @@ softSplits runs = map trimFst splits -- shortest line break. cSplits = splitTextsBy (map fst . runCharacterBreaks) runs +allowFstEmpty :: (NonEmpty a, b) -> ([a], b) +allowFstEmpty (a, b) = (NonEmpty.toList a, b) + +allowSndEmpty :: (a, NonEmpty b) -> (a, [b]) +allowSndEmpty (a, b) = (a, NonEmpty.toList b) + -- | The suffix remaining after removing the longest prefix of the list for -- which the predicate holds, except always including at least the last element -- of the original list. diff --git a/src/Data/Text/ParagraphLayout/Internal/TextContainer.hs b/src/Data/Text/ParagraphLayout/Internal/TextContainer.hs index f20379d..35bca1f 100644 --- a/src/Data/Text/ParagraphLayout/Internal/TextContainer.hs +++ b/src/Data/Text/ParagraphLayout/Internal/TextContainer.hs @@ -13,7 +13,10 @@ module Data.Text.ParagraphLayout.Internal.TextContainer ) where -import Data.List.NonEmpty (NonEmpty((:|))) +import Data.Foldable (toList) +import Data.List.NonEmpty (NonEmpty((:|)), nonEmpty) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Maybe (catMaybes) import Data.Text (Text) import qualified Data.Text as Text import Data.Text.Foreign (dropWord8, takeWord8) @@ -60,14 +63,13 @@ instance SeparableTextContainer Text where -- -- The results in the form (prefix, suffix) will be ordered from the longest -- prefix to shortest. -splitTextsBy :: SeparableTextContainer a => (a -> [Int]) -> [a] -> [([a], [a])] +splitTextsBy :: (SeparableTextContainer a, Foldable f) => + (a -> [Int]) -> f a -> [(NonEmpty a, NonEmpty a)] splitTextsBy breakFunc tcs = - filter notEmpty $ splitTextsBy' breakFunc [] (reverse tcs) - where - notEmpty (prefix, suffix) = not (null prefix || null suffix) + nonEmptyPairs $ splitTextsBy' breakFunc [] $ reverse $ toList tcs -splitTextsBy' :: SeparableTextContainer a => (a -> [Int]) -> [a] -> [a] -> - [([a], [a])] +splitTextsBy' :: SeparableTextContainer a => + (a -> [Int]) -> [a] -> [a] -> [([a], [a])] splitTextsBy' _ _ [] = [] splitTextsBy' breakFunc closed (tc:tcs) = fullSplits ++ splitTextsBy' breakFunc (tc:closed) tcs @@ -78,6 +80,18 @@ splitTextsBy' breakFunc closed (tc:tcs) = tcSplits = map (\i -> splitTextAt8 i tc) tcBreakOffsets tcBreakOffsets = breakFunc tc +-- | Turn pairs of normal lists into pairs of `NonEmpty` lists, +-- removing pairs in which either list is empty. +nonEmptyPairs :: [([a], [b])] -> [(NonEmpty a, NonEmpty b)] +nonEmptyPairs = catMaybes . map nonEmptyPair + +-- | Turn a pair of normal lists into `Just` a pair of `NonEmpty` lists, +-- or `Nothing` if either list is empty. +nonEmptyPair :: ([a], [b]) -> Maybe (NonEmpty a, NonEmpty b) +nonEmptyPair (xs, ys) = case (nonEmpty xs, nonEmpty ys) of + (Just xs1, Just ys1) -> Just (xs1, ys1) + (_, _) -> Nothing + -- | If the first container in the list is empty, remove it. collapse :: SeparableTextContainer a => NonEmpty a -> [a] collapse (tc :| tcs) @@ -89,40 +103,42 @@ collapse (tc :| tcs) -- -- Empty text containers are removed from the output, so the result may -- potentially be an empty list. -trimTextsStart :: SeparableTextContainer a => (Char -> Bool) -> [a] -> [a] -trimTextsStart p tcs = trimTextsStart' p tcs +trimTextsStart :: (SeparableTextContainer a, Foldable f) => + (Char -> Bool) -> f a -> [a] +trimTextsStart p tcs = trimTextsStart' p $ toList tcs -- | Treat a list of text containers as a contiguous sequence, -- and remove a prefix of characters that match the given predicate. -- -- Empty text containers are removed from the output except the first one, -- which is instead truncated to zero length. -trimTextsStartPreserve :: - SeparableTextContainer a => (Char -> Bool) -> [a] -> [a] -trimTextsStartPreserve _ [] = [] -trimTextsStartPreserve p ins@(in1:_) = case trimTextsStart' p ins of - [] -> [truncateText in1] - out -> out +trimTextsStartPreserve :: SeparableTextContainer a => + (Char -> Bool) -> NonEmpty a -> NonEmpty a +trimTextsStartPreserve p tcs = + case nonEmpty $ trimTextsStart p $ NonEmpty.toList tcs of + Nothing -> NonEmpty.singleton $ truncateText $ NonEmpty.head tcs + Just out -> out -- | Treat a list of text containers as a contiguous sequence, -- and remove a suffix of characters that match the given predicate. -- -- Empty text containers are removed from the output, so the result may -- potentially be an empty list. -trimTextsEnd :: SeparableTextContainer a => (Char -> Bool) -> [a] -> [a] -trimTextsEnd p tcs = trimTextsEnd' p (reverse tcs) +trimTextsEnd :: (SeparableTextContainer a, Foldable f) => + (Char -> Bool) -> f a -> [a] +trimTextsEnd p tcs = trimTextsEnd' p $ reverse $ toList tcs -- | Treat a list of text containers as a contiguous sequence, -- and remove a suffix of characters that match the given predicate. -- -- Empty text containers are removed from the output except the first one, -- which is instead truncated to zero length. -trimTextsEndPreserve :: - SeparableTextContainer a => (Char -> Bool) -> [a] -> [a] -trimTextsEndPreserve _ [] = [] -trimTextsEndPreserve p ins@(in1:_) = case trimTextsEnd' p (reverse ins) of - [] -> [truncateText in1] - out -> out +trimTextsEndPreserve :: SeparableTextContainer a => + (Char -> Bool) -> NonEmpty a -> NonEmpty a +trimTextsEndPreserve p tcs = + case nonEmpty $ trimTextsEnd p $ NonEmpty.toList tcs of + Nothing -> NonEmpty.singleton $ truncateText $ NonEmpty.head tcs + Just out -> out trimTextsStart' :: SeparableTextContainer a => (Char -> Bool) -> [a] -> [a] trimTextsStart' _ [] = [] diff --git a/test/Data/Text/ParagraphLayout/Internal/TextContainerSpec.hs b/test/Data/Text/ParagraphLayout/Internal/TextContainerSpec.hs index 9d1953d..dfb5508 100644 --- a/test/Data/Text/ParagraphLayout/Internal/TextContainerSpec.hs +++ b/test/Data/Text/ParagraphLayout/Internal/TextContainerSpec.hs @@ -1,11 +1,15 @@ module Data.Text.ParagraphLayout.Internal.TextContainerSpec (spec) where +import qualified Data.List.NonEmpty import Data.Text (Text, empty, pack) import Data.Text.Foreign (lengthWord8) import Test.Hspec import Data.Text.ParagraphLayout.Internal.TextContainer +ne :: [a] -> Data.List.NonEmpty.NonEmpty a +ne = Data.List.NonEmpty.fromList + data ExampleContainer = Contain { cText :: Text, cOffset :: Int } deriving (Show, Eq) @@ -71,32 +75,32 @@ spec = do describe "splitTextsBy" $ do it "splits example text containers" $ do splitTextsBy exampleBreakPoints exampleContainers `shouldBe` - [ ( [ contain "Vikipedija " 10, contain "(Википеди" 21 ] - , [ contain "ја)" 38 ] + [ ( ne [ contain "Vikipedija " 10, contain "(Википеди" 21 ] + , ne [ contain "ја)" 38 ] ) - , ( [ contain "Vikipedija " 10, contain "(Википе" 21 ] - , [ contain "дија)" 34 ] + , ( ne [ contain "Vikipedija " 10, contain "(Википе" 21 ] + , ne [ contain "дија)" 34 ] ) - , ( [ contain "Vikipedija " 10, contain "(Вики" 21 ] - , [ contain "педија)" 30 ] + , ( ne [ contain "Vikipedija " 10, contain "(Вики" 21 ] + , ne [ contain "педија)" 30 ] ) - , ( [ contain "Vikipedija " 10, contain "(Ви" 21 ] - , [ contain "кипедија)" 26 ] + , ( ne [ contain "Vikipedija " 10, contain "(Ви" 21 ] + , ne [ contain "кипедија)" 26 ] ) - , ( [ contain "Vikipedija " 10 ] - , [ contain "(Википедија)" 21 ] + , ( ne [ contain "Vikipedija " 10 ] + , ne [ contain "(Википедија)" 21 ] ) - , ( [ contain "Vikipedi" 10 ] - , [ contain "ja " 18, contain "(Википедија)" 21 ] + , ( ne [ contain "Vikipedi" 10 ] + , ne [ contain "ja " 18, contain "(Википедија)" 21 ] ) - , ( [ contain "Vikipe" 10 ] - , [ contain "dija " 16, contain "(Википедија)" 21 ] + , ( ne [ contain "Vikipe" 10 ] + , ne [ contain "dija " 16, contain "(Википедија)" 21 ] ) - , ( [ contain "Viki" 10 ] - , [ contain "pedija " 14, contain "(Википедија)" 21 ] + , ( ne [ contain "Viki" 10 ] + , ne [ contain "pedija " 14, contain "(Википедија)" 21 ] ) - , ( [ contain "Vi" 10 ] - , [ contain "kipedija " 12, contain "(Википедија)" 21 ] + , ( ne [ contain "Vi" 10 ] + , ne [ contain "kipedija " 12, contain "(Википедија)" 21 ] ) ] describe "trimTextsEnd" $ do -- 2.30.2