Tighten trimming for ExpandUntil and ExpandBetween

src/Test.hs

@@ -18,9 +18,9 @@ main = putStrLn $ tableString $ columnHeaderTableS
                                 ]
                                 unicodeRoundS
                                 (titlesH ["Layout", "Result"])
-                                rowGroups
+                                testRowGroups
   where
-    rowGroups    = flip concatMap styles $ \style ->
+    testRowGroups = flip concatMap styles $ \style ->
         flip map columTs $ \(cSpec, is) ->
             colsAllG center [ is
                             , genTable cSpec style

src/Text/Layout/Table.hs

@@ -392,7 +392,7 @@ tableLinesBWithCMIs TableSpec { tableStyle = TableStyle { .. }, ..  } =
         _ ->
             let attachRowHeader grps = map (\(hSpec, (grp, r)) -> (Just (hSpec, r), grp))
                                      . headerContents $ zipHeader (rowG []) grps rowHeader
-                singleColCMI = Just . deriveColModInfoFromColumnLA (expand, noAlign)
+                singleColCMI = Just . deriveColModInfoFromColumn defColSpec
             in
             ( attachRowHeader
             , singleColCMI . map snd $ headerContents rowHeader

src/Text/Layout/Table/Cell.hs

@@ -4,7 +4,7 @@
 module Text.Layout.Table.Cell where
 
 import Control.Monad (join)
-import Data.Bifunctor (bimap)
+import Data.Functor.Identity (Identity(..))
 import qualified Data.Text as T
 
 import Text.Layout.Table.Primitives.AlignInfo
@@ -46,6 +46,13 @@ redistributeAdjustment l r a = CellView (baseCell a) lAdjustment rAdjustment
     lAdjustment = (totalAdjustment a * l) `div` (l + r)
     rAdjustment = totalAdjustment a - lAdjustment
 
+-- | Add any padding in 'CellView' to a 'StringBuilder'. Any trimming will be discarded.
+cellViewToPadding :: StringBuilder b => CellView b -> b
+cellViewToPadding (CellView a l r) = padLeft $ padRight a
+  where
+    padLeft  = if l > 0 then (spacesB l <>) else id
+    padRight = if r > 0 then (<> spacesB r) else id
+
 -- | Types that can be measured for visible characters, define a sub-string
 -- operation and turned into a 'StringBuilder'.
 class Cell a where
@@ -68,8 +75,15 @@ class Cell a where
     -- substituted with 'buildCell', and is only needed for defining the
     -- instance.
     buildCellView :: StringBuilder b => CellView a -> b
+    buildCellView = cellViewToPadding . buildCellViewTight
+
+    -- | Insert the contents into a 'StringBuilder', padding or trimming as
+    -- necessary. If extra padding is needed after trimming, for example with
+    -- wide characters, this is recorded in a 'CellView'.
+    buildCellViewTight :: StringBuilder b => CellView a -> CellView b
+    buildCellViewTight = pure . buildCellView
 
-    {-# MINIMAL visibleLength, measureAlignment, buildCellView #-}
+    {-# MINIMAL visibleLength, measureAlignment, ( buildCellView | buildCellViewTight ) #-}
 
 instance Cell a => Cell (CellView a) where
     visibleLength (CellView a l r) = visibleLength a + l + r
@@ -84,12 +98,14 @@ instance Cell a => Cell (CellView a) where
         AlignInfo matchAt mMatchRemaining = measureAlignment f a
     buildCell = buildCellView
     buildCellView = buildCellView . join
+    buildCellViewTight = buildCellViewTight . join
 
 instance Cell a => Cell (Maybe a) where
     visibleLength = maybe 0 visibleLength
     measureAlignment p = maybe mempty (measureAlignment p)
     buildCell = maybe mempty buildCell
     buildCellView (CellView a l r) = maybe (spacesB $ l + r) (buildCellView . adjustCell l r) a
+    buildCellViewTight (CellView a l r) = maybe (pure . spacesB $ l + r) (buildCellViewTight . adjustCell l r) a
 
 instance (Cell a, Cell b) => Cell (Either a b) where
     visibleLength = either visibleLength visibleLength
@@ -98,6 +114,9 @@ instance (Cell a, Cell b) => Cell (Either a b) where
     buildCellView (CellView a l r) = either go go a
       where
         go x = buildCellView $ CellView x l r
+    buildCellViewTight (CellView a l r) = either go go a
+      where
+        go x = buildCellViewTight $ CellView x l r
 
 instance Cell String where
     visibleLength = length
@@ -130,7 +149,7 @@ buildCellViewLRHelper :: StringBuilder b
                       -> CellView a
                       -> b
 buildCellViewLRHelper build trimL trimR =
-    buildCellViewHelper build build build trimL trimR (\l r -> trimL l . trimR r)
+    buildCellViewHelper build (\i -> build . trimL i) (\i -> build . trimR i) (\l r -> build . trimL l . trimR r)
 
 -- | Construct 'buildCellView' from a builder function, and a function for
 -- trimming from the left and right simultaneously.
@@ -143,32 +162,46 @@ buildCellViewBothHelper
     -> CellView a
     -> b
 buildCellViewBothHelper build trimBoth =
-    buildCellViewHelper build build build (flip trimBoth 0) (trimBoth 0) trimBoth
+    buildCellViewHelper build (\i -> build . trimBoth i 0) (\i -> build . trimBoth 0 i) (\l r -> build . trimBoth l r)
 
--- | Construct 'buildCellView' from builder functions, and trimming functions.
+-- | Construct 'buildCellView' from builder functions and trimming functions.
 --
 -- Used to define instances of 'Cell'.
 buildCellViewHelper
     :: StringBuilder b
-    => (a -> b) -- ^ Builder function for 'a'.
-    -> (trimSingle -> b) -- ^ Builder function for the result of trimming 'a'.
-    -> (trimBoth -> b) -- ^ Builder function for the result of trimming 'a' twice.
-    -> (Int -> a -> trimSingle) -- ^ Function for trimming on the left.
-    -> (Int -> a -> trimSingle) -- ^ Function for trimming on the right.
-    -> (Int -> Int -> a -> trimBoth) -- ^ Function for trimming on the left and right simultaneously.
+    => (a -> b)  -- ^ Builder function for 'a'.
+    -> (Int -> a -> b)  -- ^ Function for trimming on the left.
+    -> (Int -> a -> b)  -- ^ Function for trimming on the right.
+    -> (Int -> Int -> a -> b)  -- ^ Function for trimming on the left and right simultaneously.
     -> CellView a
     -> b
-buildCellViewHelper build buildSingleTrim buildTrimBoth trimL trimR trimBoth (CellView a l r) =
+buildCellViewHelper build trimL trimR trimBoth =
+    runIdentity . buildCellViewTightHelper build
+        (\i -> Identity . trimL i) (\i -> Identity . trimR i) (\l r -> Identity . trimBoth l r)
+
+-- | Construct 'buildCellViewTight' from builder functions and trimming functions.
+--
+-- This is used to define 'buildCellViewTight' in the 'Cell' typeclass, in
+-- which `f` will be 'CellView'.
+buildCellViewTightHelper
+    :: (StringBuilder b, Applicative f)
+    => (a -> b)  -- ^ Builder function for 'a'.
+    -> (Int -> a -> f b)  -- ^ Function for trimming on the left.
+    -> (Int -> a -> f b)  -- ^ Function for trimming on the right.
+    -> (Int -> Int -> a -> f b)  -- ^ Function for trimming on the left and right simultaneously.
+    -> CellView a
+    -> f b
+buildCellViewTightHelper 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 <> buildSingleTrim (trimR (negate r) a)
-        (GT, EQ) -> spacesB l <> build a
-        (LT, GT) -> buildSingleTrim (trimL (negate l) a) <> spacesB r
-        (LT, LT) -> buildTrimBoth $ trimBoth (negate l) (negate r) a
-        (LT, EQ) -> buildSingleTrim $ trimL (negate l) a
-        (EQ, GT) -> build a <> spacesB r
-        (EQ, LT) -> buildSingleTrim $ trimR (negate r) a
-        (EQ, EQ) -> build a
+        (GT, GT) -> pure $ spacesB l <> build a <> spacesB r
+        (GT, LT) -> (spacesB l <>) <$> trimR (negate r) a
+        (GT, EQ) -> pure $ spacesB l <> build a
+        (LT, GT) -> (<> spacesB r) <$> trimL (negate l) a
+        (LT, LT) -> trimBoth (negate l) (negate r) a
+        (LT, EQ) -> trimL (negate l) a
+        (EQ, GT) -> pure $ build a <> spacesB r
+        (EQ, LT) -> trimR (negate r) a
+        (EQ, EQ) -> pure $ build a
 
 -- | Drop a number of characters from the left side. Treats negative numbers
 -- as zero.
@@ -265,7 +298,7 @@ trimOrPad :: (Cell a, StringBuilder b) => Position o -> CutMark -> Int -> a -> b
 trimOrPad p cm n c = case compare k n of
     LT -> pad' p n k c
     EQ -> buildCell c
-    GT -> trim' p cm n k c
+    GT -> cellViewToPadding $ trim' p cm n k c
   where
     k = visibleLength c
 
@@ -294,40 +327,39 @@ trimOrPadBetween
     -> a
     -> b
 trimOrPadBetween p cm lower upper c
-    | k > lower = trim' p cm upper k c
+    | k > lower = cellViewToPadding $ trim' p cm upper k c
     | k < upper = pad' p lower k c
     | otherwise = buildCell c
   where
     k = visibleLength c
 
 -- | Trim a cell based on the position. Cut marks may be trimmed if necessary.
 trim :: (Cell a, StringBuilder b) => Position o -> CutMark -> Int -> a -> b
-trim p cm n c = if k <= n then buildCell c else trim' p cm n k c
+trim p cm n c = if k <= n then buildCell c else cellViewToPadding $ trim' p cm n k c
   where
     k = visibleLength c
 
 -- | Trim a cell based on the position. Cut marks may be trimmed if necessary.
 --
+-- If extra padding is needed, it is recorded.
+--
 -- Preconditions that require to be met (otherwise the function will produce garbage):
 --
 -- prop> visibleLength c > n
 -- prop> visibleLength c == k
-trim' :: (Cell a, StringBuilder b) => Position o -> CutMark -> Int -> Int -> a -> b
+trim' :: (Cell a, StringBuilder b) => Position o -> CutMark -> Int -> Int -> a -> CellView b
 trim' p cm n k c = case p of
-    Start  -> buildCell (dropRight (cutLen + rightLen) c) <> buildCell (drop (rightLen - n) $ rightMark cm)
+    Start  -> (<> buildCell (drop (rightLen - n) $ rightMark cm)) <$> buildCellViewTight (dropRight (cutLen + rightLen) c)
+    End    -> (buildCell (take n $ leftMark cm) <>) <$> buildCellViewTight (dropLeft (cutLen + leftLen) c)
     Center -> case cutLen `divMod` 2 of
-        (0, 1) -> buildCell (take n $ leftMark cm) <> buildCell (dropLeft (1 + leftLen) c)
+        (0, 1) -> (buildCell (take n $ leftMark cm) <>) <$> buildCellViewTight (dropLeft (1 + leftLen) c)
         (q, r) -> if n >= leftLen + rightLen
-                  then buildCell (leftMark cm) <> buildCell (dropBoth (leftLen + q + r) (rightLen + q) c)
-                       <> buildCell (rightMark cm)
+                  then (buildCell (leftMark cm) <>) . (<> buildCell (rightMark cm)) <$> buildCellViewTight (dropBoth (leftLen + q + r) (rightLen + q) c)
                   else case n `divMod` 2 of
-                      (qn, rn) -> buildCell (take qn $ leftMark cm)
-                                  <> buildCell (drop (rightLen - qn - rn) $ rightMark cm)
-    End    -> buildCell (take n $ leftMark cm) <> buildCell (dropLeft (leftLen + cutLen) c)
+                      (qn, rn) -> pure $ buildCell (take qn $ leftMark cm) <> buildCell (drop (rightLen - qn - rn) $ rightMark cm)
   where
     leftLen = length $ leftMark cm
     rightLen = length $ rightMark cm
-
     cutLen = k - n
 
 -- | Align a cell by first locating the position to align with and then padding

src/Text/Layout/Table/Cell/Formatted.hs

@@ -19,7 +19,6 @@ module Text.Layout.Table.Cell.Formatted
     , cataFormatted
     ) where
 
-import Control.Monad (join)
 import Data.List (foldl', mapAccumL, mapAccumR)
 import Data.String
 
@@ -90,25 +89,54 @@ instance Cell a => Cell (Formatted a) where
     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
+        (\i -> buildFormatted buildCell . trimLeft i)
+        (\i -> buildFormatted buildCell . trimRight i)
+        (\l r -> buildFormatted buildCell . trimLeft l . trimRight r)
+    buildCellViewTight = buildCellViewTightHelper
+        (buildFormatted buildCell)
+        (\i -> buildFormattedA buildCellViewTight . trimLeft i)
+        (\i -> buildFormattedA buildCellViewTight . trimRight i)
+        (\l r -> buildFormattedA buildCellViewTight . trimLeft l . trimRight r)
 
 -- | 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)
 
+-- | Build 'Formatted' using a given constructor which returns a 'CellView'.
+buildFormattedA :: StringBuilder b => (a -> CellView b) -> Formatted a -> CellView b
+buildFormattedA build = cataFormatted (pure mempty) (fmap mconcat . sequenceA) build (\p a s -> (stringB p <>) . (<> stringB s) <$> a)
+
+trimLeft :: Cell a => Int -> Formatted a -> Formatted (CellView a)
+trimLeft i = simplifyFormatted . snd . mapAccumL (dropTrackRemaining dropLeft) i
+
+trimRight :: Cell a => Int -> Formatted a -> Formatted (CellView a)
+trimRight i = simplifyFormatted . snd . mapAccumR (dropTrackRemaining dropRight) i
+
+-- | Remove 'Nothing', empty 'Concat', and empty 'Format'.
+simplifyFormatted :: Formatted (Maybe a) -> Formatted a
+simplifyFormatted = cataFormatted Empty simplifyConcat (maybe Empty Plain) simplifyFormat
+  where
+    simplifyConcat xs = if null ys then Empty else Concat ys
+      where
+        ys = filter isNonEmpty xs
+    simplifyFormat p x s = if isNonEmpty x then Format p x s else Empty
+
+    isNonEmpty Empty = False
+    isNonEmpty _     = True
+
 -- | Drop characters either from the right or left, while also tracking the
--- remaining number of characters to drop.
-dropTrackRemaining :: Cell a => (Int -> a -> CellView a) -> Int -> a -> (Int, CellView a)
+-- remaining number of characters to drop. If all characters are dropped,
+-- return 'Nothing'.
+dropTrackRemaining :: Cell a => (Int -> a -> CellView a) -> Int -> a -> (Int, Maybe (CellView a))
 dropTrackRemaining dropF i a
-  | i <= 0    = (0, pure a)
-  | otherwise = let l = visibleLength a in (max 0 $ i - l, dropF i a)
+    -- If there is nothing left to drop, return unmodified
+    | i <= 0    = (i, Just $ pure a)
+    -- If dropping more than requested, return Nothing
+    | i >= l    = (i - l, Nothing)
+    -- Otherwise, drop what is necessary, and record the padding needed
+    | otherwise = (0, Just $ dropF i a)
+  where
+    l = visibleLength a
 
 -- | Run 'measureAlignment' with an initial state, as though we were measuring the alignment in chunks.
 mergeAlign :: Cell a => (Char -> Bool) -> AlignInfo -> a -> AlignInfo

src/Text/Layout/Table/Cell/WideString.hs

@@ -21,26 +21,44 @@ instance Cell WideString where
     visibleLength (WideString s) = realLength s
     measureAlignment p (WideString s) = measureAlignmentWide p s
     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)
+    buildCellViewTight = buildCellViewTightHelper
+        (\(WideString s) -> buildCell s)
+        (\i (WideString s) -> buildCell <$> trimLeft i s)
+        (\i (WideString s) -> buildCell <$> trimRight i s)
+        (\l r (WideString s) ->
+            -- First try to trim from the right.
+            let CellView a _ rightAdj = trimRight r s in
+            -- If there is extra padding, trim less on the left.
+            buildCell <$> trimLeft (l - rightAdj) a
+        )
 
 -- | Drop characters from the left side of a 'String' until at least the
 -- provided width has been removed.
 --
 -- The provided `Bool` determines whether to continue dropping zero-width
 -- characters after the requested width has been dropped.
-dropWide :: Bool -> Int -> String -> String
-dropWide _ _ [] = []
+dropWide :: Bool -> Int -> String -> CellView String
+dropWide _ _ [] = pure ""
 dropWide gobbleZeroWidth i l@(x : xs)
     | gobbleZeroWidth && i == 0 && charLen == 0 = dropWide gobbleZeroWidth i xs
-    | i <= 0       = l
+    | i <= 0       = pure l
     | charLen <= i = dropWide gobbleZeroWidth (i - charLen) xs
-    | otherwise    = replicate (charLen - i) ' ' ++ dropWide gobbleZeroWidth 0 xs
+    | otherwise    = adjustCell (charLen - i) 0 =<< dropWide gobbleZeroWidth 0 xs
   where
     charLen = charWidth x
 
+-- | Drop characters from the left side of a 'String', recording how much padding
+-- is needed to have dropped the requested width.
+trimLeft :: Int -> String -> CellView String
+trimLeft = dropWide True
+
+-- | Drop characters from the right side of a 'String', recording how much padding
+-- is needed to have dropped the requested width.
+trimRight :: Int -> String -> CellView String
+trimRight i = swapAdjustment . fmap reverse . dropWide False i . reverse
+  where
+    swapAdjustment (CellView a l r) = CellView a r l
+
 measureAlignmentWide :: (Char -> Bool) -> String -> AlignInfo
 measureAlignmentWide p xs = case break p xs of
     (ls, rs) -> AlignInfo (realLength ls) $ case rs of
@@ -55,27 +73,33 @@ instance Cell WideText where
     visibleLength (WideText s) = realLength s
     measureAlignment p (WideText s) = measureAlignmentWideT p s
     buildCell (WideText s) = buildCell s
-    buildCellView = buildCellViewLRHelper
+    buildCellViewTight = buildCellViewTightHelper
         (\(WideText s) -> buildCell s)
-        (\i (WideText s) -> WideText $ dropLeftWideT i s)
-        (\i (WideText s) -> WideText $ dropRightWideT i s)
+        (\i (WideText s) -> buildCell <$> dropLeftWideT i s)
+        (\i (WideText s) -> buildCell <$> dropRightWideT i s)
+        (\l r (WideText s) ->
+            -- First try to trim from the right.
+            let CellView a _ rightAdj = dropRightWideT r s in
+            -- If there is extra padding, trim less on the left.
+            buildCell <$> dropLeftWideT (l - rightAdj) a
+        )
 
-dropLeftWideT :: Int -> T.Text -> T.Text
+dropLeftWideT :: Int -> T.Text -> CellView T.Text
 dropLeftWideT i txt = case T.uncons txt of
-    Nothing -> txt
+    Nothing -> pure txt
     Just (x, xs) -> let l = charWidth x in if
         | i == 0 && l == 0 -> dropLeftWideT i xs
-        | i <= 0    -> txt
+        | i <= 0    -> pure txt
         | l <= i    -> dropLeftWideT (i - l) xs
-        | otherwise -> T.replicate (l - i) " " <> dropLeftWideT 0 xs
+        | otherwise -> adjustCell (l - i) 0 =<< dropLeftWideT 0 xs
 
-dropRightWideT :: Int -> T.Text -> T.Text
+dropRightWideT :: Int -> T.Text -> CellView T.Text
 dropRightWideT i txt = case T.unsnoc txt of
-    Nothing -> txt
+    Nothing -> pure txt
     Just (xs, x) -> let l = charWidth x in if
-        | i <= 0    -> txt
+        | i <= 0    -> pure txt
         | l <= i    -> dropRightWideT (i - l) xs
-        | otherwise -> xs <> T.replicate (l - i) " "
+        | otherwise -> adjustCell 0 (l - i) xs
 
 measureAlignmentWideT :: (Char -> Bool) -> T.Text -> AlignInfo
 measureAlignmentWideT p xs = case T.break p xs of