Do not pad when finding max length in ExpandUntil

src/Text/Layout/Table/Cell.hs

@@ -32,6 +32,21 @@ class Cell a where
     -- output medium.
     visibleLength :: a -> Int
 
+    -- | A decreasing list of natural truncation lengths of this cell from the
+    -- left, or 'Nothing' if all truncations are natural. It is always safe to
+    -- leave this as the default implementation, but you can sometimes get
+    -- tighter bounds with 'ExpandUntil' with a custom definition.
+    visibleLengthLeftTruncations :: a -> Maybe [Int]
+    visibleLengthLeftTruncations = const Nothing
+
+    -- | As above, but for right truncations
+    visibleLengthRightTruncations :: a -> Maybe [Int]
+    visibleLengthRightTruncations = const Nothing
+
+    -- | As above, but for center truncations
+    visibleLengthCenterTruncations :: a -> Maybe [Int]
+    visibleLengthCenterTruncations = const Nothing
+
     -- | Measure the preceeding and following characters for a position where
     -- the predicate matches.
     measureAlignment :: (Char -> Bool) -> a -> AlignInfo

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

@@ -6,6 +6,7 @@ module Text.Layout.Table.Cell.WideString
     , WideText(..)
     ) where
 
+import Data.List (inits, tails)
 import Data.String
 import qualified Data.Text as T
 import Text.DocLayout
@@ -22,6 +23,8 @@ 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
+    visibleLengthLeftTruncations (WideString s) = Just . map realLength $ tails s
+    visibleLengthRightTruncations (WideString s) = Just . map realLength . reverse $ inits s
     measureAlignment p (WideString s) = measureAlignmentWide p s
     buildCell (WideString s) = buildCell s
 
@@ -54,6 +57,8 @@ 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
+    visibleLengthLeftTruncations (WideText s) = Just . map realLength $ T.tails s
+    visibleLengthRightTruncations (WideText s) = Just . map realLength . reverse $ T.inits s
     measureAlignment p (WideText s) = measureAlignmentWideT p s
     buildCell (WideText s) = buildCell s
 

src/Text/Layout/Table/Primitives/ColumnModifier.hs

@@ -1,7 +1,9 @@
 module Text.Layout.Table.Primitives.ColumnModifier where
 
-import Control.Arrow ((&&&))
-import Data.List
+import Control.Arrow  ((&&&))
+import Data.Bifunctor (bimap, first)
+import Data.List      (find, transpose)
+import Data.Maybe     (fromMaybe)
 
 import Text.Layout.Table.Cell
 import Text.Layout.Table.Primitives.AlignInfo
@@ -92,22 +94,34 @@ columnModifier pos cms colModInfo = case colModInfo of
     FitTo lim mT      ->
         maybe (trimOrPad pos cms lim) (uncurry $ alignFixed pos cms lim) mT
 
--- | Derive the 'ColModInfo' by using layout specifications and the actual cells
--- of a column. This function only needs to know about 'LenSpec' and 'AlignInfo'.
-deriveColModInfos :: Cell a => [(LenSpec, AlignSpec)] -> [Row a] -> [ColModInfo]
+-- | Derive the 'ColModInfo' by using layout specifications and the actual
+-- cells of a column. This function only needs to know about 'LenSpec',
+-- 'Position H', and 'AlignInfo'.
+deriveColModInfos :: Cell a => [(LenSpec, Position H, AlignSpec)] -> [Row a] -> [ColModInfo]
 deriveColModInfos specs = zipWith ($) (fmap fSel specs) . transpose
   where
-    fSel (lenS, alignS) = case alignS of
+    fSel (lenS, posS, alignS) = case alignS of
         NoAlign     -> let fitTo i              = const $ FitTo i Nothing
-                           expandUntil' f i max' = if f (max' <= i)
-                                                   then FillTo max'
-                                                   else fitTo i max'
+                           expandUntil' i (max', max'') = if max' <= i
+                                                          then FillTo max'
+                                                          else fitTo (min i max'') max'
+                           fixedUntil' i max' = if max' > i
+                                                then FillTo max'
+                                                else fitTo i max'
                            fun                  = case lenS of
-                               Expand        -> FillTo
-                               Fixed i       -> fitTo i
-                               ExpandUntil i -> expandUntil' id i
-                               FixedUntil i  -> expandUntil' not i
-                       in fun . maximum . map visibleLength
+                               Expand        -> FillTo . fst
+                               Fixed i       -> fitTo i . fst
+                               ExpandUntil i -> expandUntil' i
+                               FixedUntil i  -> fixedUntil' i . fst
+                           maxLenCell i f a     = let l = visibleLength a
+                                                  in (l, maybe l (fromMaybe 0 . find (i>=)) $ f a)
+                           maxLen               = case lenS of
+                               ExpandUntil i -> case posS of
+                                                  Start  -> maxLenCell i visibleLengthRightTruncations
+                                                  End    -> maxLenCell i visibleLengthLeftTruncations
+                                                  Center -> maxLenCell i visibleLengthCenterTruncations
+                               _             -> \a -> let l = visibleLength a in (l, l)
+                       in fun . bimap maximum maximum . unzip . map maxLen
         AlignOcc oS -> let fitToAligned i      = FitTo i . Just . (,) oS
                            fillAligned         = FillAligned oS
                            expandUntil' f i ai = if f (widthAI ai <= i)
@@ -121,7 +135,7 @@ deriveColModInfos specs = zipWith ($) (fmap fSel specs) . transpose
                         in fun . foldMap (deriveAlignInfo oS)
 
 deriveColModInfos' :: Cell a => [ColSpec] -> [Row a] -> [ColModInfo]
-deriveColModInfos' = deriveColModInfos . fmap (lenSpec &&& alignSpec)
+deriveColModInfos' = deriveColModInfos . fmap (\c -> (lenSpec c, position c, alignSpec c))
 
 -- | Derive the 'ColModInfo' and generate functions without any intermediate
 -- steps.

test-suite/TestSpec.hs

@@ -16,6 +16,7 @@ import Text.Layout.Table.Cell.WideString (WideString(..), WideText(..))
 import Text.Layout.Table.Spec.OccSpec
 import Text.Layout.Table.Primitives.Basic
 import Text.Layout.Table.Primitives.AlignInfo
+import Text.Layout.Table.Primitives.ColumnModifier
 import Text.Layout.Table.Justify
 import Text.Layout.Table.Cell.Formatted
 
@@ -234,6 +235,14 @@ spec = do
             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û"
+        describe "deriveColMods" $ do
+            describe "will not add extra padding under expandUntil when unnecessary" $ do
+                let col pos = column (expandUntil 3) pos noAlign noCutMark
+                    str = WideString "㐁㐂"
+                it "when dropping from the right" $
+                    zipWith ($) (deriveColMods [col left] [[str]]) [str] `shouldBe` ["㐁"]
+                it "when dropping from the left" $
+                    zipWith ($) (deriveColMods [col right] [[str]]) [str] `shouldBe` ["㐂"]
 
     describe "wide text" $ do
         describe "buildCell" $ do