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