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,31 @@ 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
-        NoAlign     -> let fitTo i              = const $ FitTo i Nothing
-                           expandUntil' f i max' = if f (max' <= i)
-                                                   then FillTo max'
-                                                   else fitTo i max'
+    fSel (lenS, posS, alignS) = case alignS of
+        NoAlign     -> let fitTo i             = const $ FitTo i Nothing
+                           expandUntil' i max' = 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
+                               ExpandUntil i -> expandUntil' i
+                               FixedUntil i  -> fixedUntil' i
+                           maxLenCell i f       = maybe i (fromMaybe 0 . find (i>=)) . f
+                           maxLen               = case lenS of
+                               ExpandUntil i -> case posS of
+                                                  Start  -> maxLenCell i visibleLengthRightTruncations
+                                                  End    -> maxLenCell i visibleLengthLeftTruncations
+                                                  Center -> maxLenCell i visibleLengthCenterTruncations
+                               _             -> visibleLength
+                       in fun . maximum . 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 +132,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
 
@@ -246,6 +247,24 @@ spec = do
             prop "gives the same result as wide string" $ \(Small n) x -> buildCell (dropLeft n . WideText $ T.pack x) `shouldBe` (buildCell . dropLeft n $ WideString x :: String)
         describe "dropRight" $ do
             prop "gives the same result as wide string" $ \(Small n) x -> buildCell (dropRight n . WideText $ T.pack x) `shouldBe` (buildCell . dropRight n $ WideString x :: String)
+
+    describe "grid" $ do
+        describe "expandUntil" $ do
+            let col pos = column (expandUntil 7) pos noAlign noCutMark
+                wide = "A long string"
+                narrow = "Short"
+            it "when dropping from the right" $
+                grid [col left]  [[wide], [narrow]] `shouldBe` [["A long "], ["Short  "]]
+            it "when dropping from the left" $
+                grid [col right] [[wide], [narrow]] `shouldBe` [[" string"], ["  Short"]]
+            describe "when not all truncations are natural, will not add extra padding" $ do
+                let col pos = column (expandUntil 3) pos noAlign noCutMark
+                    wide = WideString "㐁㐂"
+                    narrow = WideString "ab"
+                it "when dropping from the right" $
+                    grid [col left] [[wide], [narrow]] `shouldBe` [["㐁"], ["ab"]]
+                it "when dropping from the left" $
+                    grid [col right] [[wide], [narrow]] `shouldBe` [["㐂"], ["ab"]]
   where
     customCM = doubleCutMark "<.." "..>"
     unevenCM = doubleCutMark "<" "-->"