Make Cell lazier to allow more instances

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

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

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.

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

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