From 3379c2436a2aaabb5d540e19cc7f75c3ca506382 Mon Sep 17 00:00:00 2001 From: Stephen Morgan Date: Sat, 29 Oct 2022 10:54:08 +1100 Subject: [PATCH] Make Cell lazier to allow more instances Previously Cell required being able to drop from the left or right without changing the type of the object. This made it awkward to define instances for which this was not natural. Cell will no longer drop from the left or right immediately. Instead, drop(Left|Right|Both) will record the amount that has been requested to be dropped, and drop it when buildCell is called. Changes to the API require that instance declarations for Cell be changed as follows: 1. instance Cell a where dropLeft = f dropRight = g ... can be changed to instance Cell a where buildCellView = buildCellViewLRHelper buildCell f g ... 2. instance Cell a where dropBoth = f ... can be changed to instance Cell a where buildCellView = buildCellViewBothHelper buildCell f ... 3. instance Cell a where dropLeft = f dropRight = g dropBoth = h ... can be changed to instance Cell a where buildCellView = buildCellViewHelper buildCell buildCell buildCell f g h ... Since dropLeft, dropRight, and dropBoth are no longer class methods of Cell, they may need to be imported explicitly. Code which relies on dropLeft, dropRight, and dropBoth not changing the type of the output may need to be rewritten, possibly by calling buildCell on the result. --- src/Text/Layout/Table.hs | 1 + src/Text/Layout/Table/Cell.hs | 157 +++++++++++++++++++---- src/Text/Layout/Table/Cell/Formatted.hs | 25 +++- src/Text/Layout/Table/Cell/WideString.hs | 12 +- test-suite/TestSpec.hs | 22 ++-- 5 files changed, 169 insertions(+), 48 deletions(-) diff --git a/src/Text/Layout/Table.hs b/src/Text/Layout/Table.hs index 429b740..f8688ea 100644 --- a/src/Text/Layout/Table.hs +++ b/src/Text/Layout/Table.hs @@ -115,6 +115,7 @@ module Text.Layout.Table , trimOrPadBetween , align , alignFixed + , adjustCell -- * Column modifaction primitives -- | These functions are provided to be reused. For example if someone diff --git a/src/Text/Layout/Table/Cell.hs b/src/Text/Layout/Table/Cell.hs index eef5964..7b12592 100644 --- a/src/Text/Layout/Table/Cell.hs +++ b/src/Text/Layout/Table/Cell.hs @@ -1,6 +1,9 @@ +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleInstances #-} + module Text.Layout.Table.Cell where +import Control.Monad (join) import Data.Bifunctor (bimap) import qualified Data.Text as T @@ -10,30 +13,47 @@ import Text.Layout.Table.Spec.OccSpec import Text.Layout.Table.Spec.Position import Text.Layout.Table.StringBuilder --- | Types that can be shortened, measured for visible characters, and turned --- into a 'StringBuilder'. -class Cell a where - -- Preprocessing functions: - -- | Drop a number of characters from the left side. Treats negative numbers - -- as zero. - dropLeft :: Int -> a -> a - dropLeft n = dropBoth n 0 +-- | An object along with the amount that its length should be adjusted on both the left and right. +-- Positive numbers are padding and negative numbers are trimming. +data CellView a = + CellView + { baseCell :: a + , leftAdjustment :: Int + , rightAdjustment :: Int + } deriving (Eq, Ord, Show, Functor) + +instance Applicative CellView where + pure x = CellView x 0 0 + (CellView f l r) <*> (CellView x l' r') = CellView (f x) (l + l') (r + r') - -- | Drop a number of characters from the right side. Treats negative - -- numbers as zero. - dropRight :: Int -> a -> a - dropRight = dropBoth 0 +instance Monad CellView where + (CellView x l r) >>= f = let CellView y l' r' = f x in CellView y (l + l') (r + r') - -- | Drop characters from both sides. Treats negative numbers as zero. - dropBoth :: Int -> Int -> a -> a - dropBoth l r = dropRight r . dropLeft l +-- | Add an adjustment to the left and right of a 'Cell'. +-- Positive numbers are padding and negative numbers are trimming. +adjustCell :: Int -> Int -> a -> CellView a +adjustCell l r a = CellView a l r +-- | The total amount of adjustment in 'CellView'. +totalAdjustment :: CellView a -> Int +totalAdjustment a = leftAdjustment a + rightAdjustment a + +-- | Redistribute padding or trimming using a given ratio. +redistributeAdjustment :: Int -> Int -> CellView a -> CellView a +redistributeAdjustment l r a = CellView (baseCell a) lAdjustment rAdjustment + where + lAdjustment = (totalAdjustment a * l) `div` (l + r) + rAdjustment = totalAdjustment a - lAdjustment + +-- | Types that can be shortened, measured for visible characters, and turned +-- into a 'StringBuilder'. +class Cell a where -- | Returns the length of the visible characters as displayed on the -- output medium. visibleLength :: a -> Int - -- | Measure the preceeding and following characters for a position where + -- | Measure the preceding and following characters for a position where -- the predicate matches. measureAlignment :: (Char -> Bool) -> a -> AlignInfo @@ -43,41 +63,124 @@ class Cell a where -- | Insert the contents into a 'StringBuilder'. buildCell :: StringBuilder b => a -> b - - {-# MINIMAL visibleLength, measureAlignment, emptyCell, buildCell, (dropBoth | (dropLeft, dropRight)) #-} + buildCell = buildCellView . pure + + -- | Insert the contents into a 'StringBuilder', padding or trimming as + -- necessary. + -- + -- The 'Cell' instance of 'CellView a' means that this can usually be + -- substituted with 'buildCell', and is only needed for defining the + -- instance. + buildCellView :: StringBuilder b => CellView a -> b + + {-# MINIMAL visibleLength, measureAlignment, emptyCell, buildCellView #-} + +instance Cell a => Cell (CellView a) where + visibleLength (CellView a l r) = visibleLength a + l + r + measureAlignment f (CellView a l r) = case mMatchRemaining of + -- No match + Nothing -> AlignInfo (max 0 $ matchAt + l + r) Nothing + -- There is a match, but it is cut off from the left or right + Just matchRemaining | matchAt < -l || matchRemaining < -r -> AlignInfo (max 0 $ matchAt + matchRemaining + 1 + l + r) Nothing + -- There is a match, and it is not cut off + Just matchRemaining -> AlignInfo (matchAt + l) (Just $ matchRemaining + r) + where + AlignInfo matchAt mMatchRemaining = measureAlignment f a + emptyCell = pure emptyCell + buildCell = buildCellView + buildCellView = buildCellView . join instance (Cell a, Cell b) => Cell (Either a b) where - dropLeft n = bimap (dropLeft n) (dropLeft n) - dropRight n = bimap (dropRight n) (dropRight n) - dropBoth l r = bimap (dropBoth l r) (dropBoth l r) visibleLength = either visibleLength visibleLength measureAlignment p = either (measureAlignment p) (measureAlignment p) emptyCell = Right emptyCell buildCell = either buildCell buildCell + buildCellView (CellView a l r) = either go go a + where + go x = buildCellView $ CellView x l r instance Cell String where - dropLeft = drop - dropRight n s = zipWith const s (drop n s) visibleLength = length measureAlignment p xs = case break p xs of (ls, rs) -> AlignInfo (length ls) $ case rs of [] -> Nothing _ : rs' -> Just $ length rs' - emptyCell = "" buildCell = stringB + buildCellView = buildCellViewLRHelper stringB drop (\n s -> zipWith const s $ drop n s) instance Cell T.Text where - dropLeft = T.drop - dropRight = T.dropEnd visibleLength = T.length measureAlignment p xs = case T.break p xs of (ls, rs) -> AlignInfo (T.length ls) $ if T.null rs then Nothing else Just $ T.length rs - 1 - emptyCell = T.pack "" buildCell = textB + buildCellView = buildCellViewLRHelper textB T.drop T.dropEnd + +-- | Construct 'buildCellView' from a builder function, a function for +-- trimming from the left, and a function for trimming from the right. +-- +-- Used to define instances of 'Cell'. +buildCellViewLRHelper :: StringBuilder b + => (a -> b) -- ^ Builder function for 'a'. + -> (Int -> a -> a) -- ^ Function for trimming on the left. + -> (Int -> a -> a) -- ^ Function for trimming on the right. + -> CellView a + -> b +buildCellViewLRHelper build trimL trimR = + buildCellViewHelper build build build trimL trimR (\l r -> trimL l . trimR r) + +-- | Construct 'buildCellView' from a builder function, and a function for +-- trimming from the left and right simultaneously. +-- +-- Used to define instanced of 'Cell'. +buildCellViewBothHelper :: StringBuilder b + => (a -> b) -- ^ Builder function for 'a'. + -> (Int -> Int -> a -> a) -- ^ Function for trimming on the left and right simultaneously. + -> CellView a + -> b +buildCellViewBothHelper build trimBoth = + buildCellViewHelper build build build (flip trimBoth 0) (trimBoth 0) trimBoth + +-- | Construct 'buildCellView' from builder functions, and trimming functions. +-- +-- Used to define instances of 'Cell'. +buildCellViewHelper :: StringBuilder b + => (a -> b) -- ^ Builder function for 'a'. + -> (a' -> b) -- ^ Builder function for the result of trimming 'a'. + -> (a'' -> b) -- ^ Builder function for the result of trimming 'a' twice. + -> (Int -> a -> a') -- ^ Function for trimming on the left. + -> (Int -> a -> a') -- ^ Function for trimming on the right. + -> (Int -> Int -> a -> a'') -- ^ Function for trimming on the left and right simultaneously. + -> CellView a + -> b +buildCellViewHelper build build' build'' trimL trimR trimBoth (CellView a l r) = + case (compare l 0, compare r 0) of + (GT, GT) -> spacesB l <> build a <> spacesB r + (GT, LT) -> spacesB l <> build' (trimR (negate r) a) + (GT, EQ) -> spacesB l <> build a + (LT, GT) -> build' (trimL (negate l) a) <> spacesB r + (LT, LT) -> build'' $ trimBoth (negate l) (negate r) a + (LT, EQ) -> build' $ trimL (negate l) a + (EQ, GT) -> build a <> spacesB r + (EQ, LT) -> build' $ trimR (negate r) a + (EQ, EQ) -> build a + +-- | Drop a number of characters from the left side. Treats negative numbers +-- as zero. +dropLeft :: Int -> a -> CellView a +dropLeft n = dropBoth n 0 + +-- | Drop a number of characters from the right side. Treats negative +-- numbers as zero. +dropRight :: Int -> a -> CellView a +dropRight = dropBoth 0 + +-- | Drop characters from both sides. Treats negative numbers as zero. +dropBoth :: Int -> Int -> a -> CellView a +dropBoth l r = adjustCell (- max 0 l) (- max 0 r) remSpacesB :: (Cell a, StringBuilder b) => Int -> a -> b remSpacesB n c = remSpacesB' n $ visibleLength c diff --git a/src/Text/Layout/Table/Cell/Formatted.hs b/src/Text/Layout/Table/Cell/Formatted.hs index 7c6e0d7..c78c7f3 100644 --- a/src/Text/Layout/Table/Cell/Formatted.hs +++ b/src/Text/Layout/Table/Cell/Formatted.hs @@ -16,6 +16,7 @@ module Text.Layout.Table.Cell.Formatted , cataFormatted ) where +import Control.Monad (join) import Data.List (foldl', mapAccumL, mapAccumR) import Data.String @@ -81,18 +82,30 @@ instance Monoid (Formatted a) where mempty = Empty instance Cell a => Cell (Formatted a) where - dropLeft i = snd . mapAccumL (dropTrackRemaining dropLeft) i - dropRight i = snd . mapAccumR (dropTrackRemaining dropRight) i visibleLength = sum . fmap visibleLength measureAlignment p = foldl' (mergeAlign p) mempty - emptyCell = mempty - buildCell = cataFormatted mempty mconcat buildCell (\p a s -> stringB p <> a <> stringB s) + emptyCell = plain emptyCell + buildCell = buildFormatted buildCell + buildCellView = buildCellViewHelper + (buildFormatted buildCell) + (buildFormatted buildCellView) + (buildFormatted buildCellView) + trimLeft + trimRight + (\l r -> trimLeft l . trimRight r) + where + trimLeft i = snd . mapAccumL (dropTrackRemaining dropLeft) i + trimRight i = snd . mapAccumR (dropTrackRemaining dropRight) i + +-- | Build 'Formatted' using a given constructor. +buildFormatted :: StringBuilder b => (a -> b) -> Formatted a -> b +buildFormatted build = cataFormatted mempty mconcat build (\p a s -> stringB p <> a <> stringB s) -- | Drop characters either from the right or left, while also tracking the -- remaining number of characters to drop. -dropTrackRemaining :: Cell a => (Int -> a -> a) -> Int -> a -> (Int, a) +dropTrackRemaining :: Cell a => (Int -> a -> CellView a) -> Int -> a -> (Int, CellView a) dropTrackRemaining dropF i a - | i <= 0 = (0, a) + | i <= 0 = (0, pure a) | otherwise = let l = visibleLength a in (max 0 $ i - l, dropF i a) -- | Run 'measureAlignment' with an initial state, as though we were measuring the alignment in chunks. diff --git a/src/Text/Layout/Table/Cell/WideString.hs b/src/Text/Layout/Table/Cell/WideString.hs index 003ea19..14cae3b 100644 --- a/src/Text/Layout/Table/Cell/WideString.hs +++ b/src/Text/Layout/Table/Cell/WideString.hs @@ -18,12 +18,14 @@ newtype WideString = WideString String deriving (Eq, Ord, Show, Read, Semigroup, Monoid, IsString) instance Cell WideString where - dropLeft i (WideString s) = WideString $ dropWide True i s - dropRight i (WideString s) = WideString . reverse . dropWide False i $ reverse s visibleLength (WideString s) = realLength s measureAlignment p (WideString s) = measureAlignmentWide p s emptyCell = WideString "" buildCell (WideString s) = buildCell s + buildCellView = buildCellViewLRHelper + (\(WideString s) -> buildCell s) + (\i (WideString s) -> WideString $ dropWide True i s) + (\i (WideString s) -> WideString . reverse . dropWide False i $ reverse s) -- | Drop characters from the left side of a 'String' until at least the -- provided width has been removed. @@ -51,12 +53,14 @@ newtype WideText = WideText T.Text deriving (Eq, Ord, Show, Read, Semigroup, Monoid, IsString) instance Cell WideText where - dropLeft i (WideText s) = WideText $ dropLeftWideT i s - dropRight i (WideText s) = WideText $ dropRightWideT i s visibleLength (WideText s) = realLength s measureAlignment p (WideText s) = measureAlignmentWideT p s emptyCell = WideText "" buildCell (WideText s) = buildCell s + buildCellView = buildCellViewLRHelper + (\(WideText s) -> buildCell s) + (\i (WideText s) -> WideText $ dropLeftWideT i s) + (\i (WideText s) -> WideText $ dropRightWideT i s) dropLeftWideT :: Int -> T.Text -> T.Text dropLeftWideT i txt = case T.uncons txt of diff --git a/test-suite/TestSpec.hs b/test-suite/TestSpec.hs index 020f0e0..704b190 100644 --- a/test-suite/TestSpec.hs +++ b/test-suite/TestSpec.hs @@ -14,7 +14,7 @@ import Test.Hspec.QuickCheck import Test.QuickCheck import Text.Layout.Table -import Text.Layout.Table.Cell (Cell(..), CutAction(..), CutInfo(..), applyCutInfo, determineCutAction, determineCuts, viewRange) +import Text.Layout.Table.Cell (Cell(..), CutAction(..), CutInfo(..), applyCutInfo, determineCutAction, determineCuts, dropLeft, dropRight, viewRange) import Text.Layout.Table.Cell.WideString (WideString(..), WideText(..)) import Text.Layout.Table.Spec.AlignSpec import Text.Layout.Table.Spec.CutMark @@ -304,21 +304,21 @@ spec = do it "detects zero width after" $ measureAlignmentAt 'n' narrow `shouldBe` AlignInfo 3 (Just 5) it "detects zero width before" $ measureAlignmentAt 'r' narrow `shouldBe` AlignInfo 7 (Just 1) describe "dropLeft" $ do - prop "agrees for ascii strings" $ \(Small n) (NonControlASCIIString x) -> buildCell (dropLeft n (WideString x)) `shouldBe` dropLeft n x + prop "agrees for ascii strings" $ \(Small n) (NonControlASCIIString x) -> buildCell (dropLeft n (WideString x)) `shouldBe` (buildCell (dropLeft n x) :: String) describe "on wide characters" $ do - it "drops 1 character of double width" $ dropLeft 2 wide `shouldBe` WideString "㐁㐂" - it "drops 2 characters of double width and adds a space" $ dropLeft 3 wide `shouldBe` WideString " 㐂" + it "drops 1 character of double width" $ buildCell (dropLeft 2 wide) `shouldBe` "㐁㐂" + it "drops 2 characters of double width and adds a space" $ buildCell (dropLeft 3 wide) `shouldBe` " 㐂" describe "on narrow characters" $ do - it "drops combining characters with their previous" $ dropLeft 7 narrow `shouldBe` WideString "r!" - it "drops combining characters after a dropped wide character which overshoots" $ dropLeft 1 (WideString "㐀̈㐁") `shouldBe` WideString " 㐁" + it "drops combining characters with their previous" $ buildCell (dropLeft 7 narrow) `shouldBe` "r!" + it "drops combining characters after a dropped wide character which overshoots" $ buildCell (dropLeft 1 (WideString "㐀̈㐁")) `shouldBe` " 㐁" describe "dropRight" $ do - prop "agrees for ascii strings" $ \(Small n) (NonControlASCIIString x) -> buildCell (dropRight n (WideString x)) `shouldBe` dropRight n x + prop "agrees for ascii strings" $ \(Small n) (NonControlASCIIString x) -> buildCell (dropRight n (WideString x)) `shouldBe` (buildCell (dropRight n x) :: String) describe "on wide characters" $ do - it "drops 1 character of double width" $ dropRight 2 wide `shouldBe` WideString "㐀㐁" - it "drops 2 characters of double width and adds a space" $ dropRight 3 wide `shouldBe` WideString "㐀 " + it "drops 1 character of double width" $ buildCell (dropRight 2 wide) `shouldBe` "㐀㐁" + it "drops 2 characters of double width and adds a space" $ buildCell (dropRight 3 wide) `shouldBe` "㐀 " describe "on narrow characters" $ do - it "drops a combining character for free" $ dropRight 3 narrow `shouldBe` WideString "Bien s" - it "does not drop a combining character without their previous" $ dropRight 2 narrow `shouldBe` WideString "Bien sû" + it "drops a combining character for free" $ buildCell (dropRight 3 narrow) `shouldBe` "Bien s" + it "does not drop a combining character without their previous" $ buildCell (dropRight 2 narrow) `shouldBe` "Bien sû" describe "wide text" $ do describe "buildCell" $ do