diff --git a/src/Text/Layout/Table.hs b/src/Text/Layout/Table.hs index d15080a..381079a 100644 --- a/src/Text/Layout/Table.hs +++ b/src/Text/Layout/Table.hs @@ -263,13 +263,13 @@ checkeredCells f g = zipWith altLines $ cycle [[f, g], [g, f]] -- | Create a 'RowGroup' by aligning the columns vertically. The position is -- specified for each column. -colsG :: Cell a => [Position V] -> [Col a] -> RowGroup a -colsG ps = rowsG . colsAsRows ps +colsG :: [Position V] -> [Col a] -> RowGroup a +colsG ps = nullableRowsG . colsAsRows ps -- | Create a 'RowGroup' by aligning the columns vertically. Each column uses -- the same vertical positioning. -colsAllG :: Cell a => Position V -> [Col a] -> RowGroup a -colsAllG p = rowsG . colsAsRowsAll p +colsAllG :: Position V -> [Col a] -> RowGroup a +colsAllG p = nullableRowsG . colsAsRowsAll p -- | Layouts a pretty table with an optional header. Note that providing fewer -- layout specifications than columns or vice versa will result in not showing @@ -317,18 +317,19 @@ tableLinesBWithCMIs specs TableStyle { .. } rowHeader colHeader rowGroups = -- | Replace the content of a 'HeaderSpec' with the content of the rows or columns to be rendered, -- and flatten to a list of content interspersed with column/row separators. If given 'NoneHS', first -- replace it with the shape of the data. - flattenWithContent (NoneHS sep) content r = flattenHeader . fmap fst . zipHeader mempty r . fullSepH sep (repeat defHeaderColSpec) $ () <$ content - flattenWithContent h _ r = flattenHeader . fmap fst $ zipHeader mempty r h + flattenWithContent (NoneHS sep) contentShape r = flattenHeader . fmap fst . zipHeader mempty r $ fullSepH sep (repeat defHeaderColSpec) contentShape + flattenWithContent h _ r = flattenHeader . fmap fst $ zipHeader mempty r h -- | Intersperse a row with its rendered separators. withRowSeparators :: (hSep -> Maybe b) -> [Row b] -> [Either (Maybe b) (Row b)] withRowSeparators renderDelimiter = map (first renderDelimiter) . flattenWithContent rowHeader rowGroups + -- | Intersperse a column with its rendered separators, including an optional row header. withColSeparators :: (vSep -> String) -> (Maybe b, Row b) -> (Maybe b, Row (Either String b)) withColSeparators renderDelimiter = second renderRow where renderRow = map (first renderIfDrawn) . flattenWithContent colHeader columns - columns = fromMaybe [] $ listToMaybe . rows =<< listToMaybe rowGroups + columns = maybe [] rowGroupShape $ listToMaybe rowGroups -- Render the delimiters of a column if it is drawn, otherwise return an empty string. renderIfDrawn x -- If no delimiters are drawn in this column, return the empty string @@ -399,8 +400,7 @@ tableLinesBWithCMIs specs TableStyle { .. } rowHeader colHeader rowGroups = ) _ -> let headerLine = horizontalContentLine headerL headerR bothHeadersR $ withColSeparators headerC - (emptyHeaderCell <$> rowHeaderCMI, headerRowMods hTitles) - emptyHeaderCell cmi = headerCellModifier def noCutMark cmi (emptyCell :: c) + (emptyFromCMI <$> rowHeaderCMI, headerRowMods hTitles) headerRowMods = zipWith4 headerCellModifier headerColSpecs cMSs @@ -416,11 +416,15 @@ tableLinesBWithCMIs specs TableStyle { .. } rowHeader colHeader rowGroups = , bothHeadersT ) + emptyFromCMI = spacesB . widthCMI + cMSs = map cutMark specs posSpecs = map position specs - cMIs = fitHeaderIntoCMIs $ deriveColModInfos' specs $ concatMap rows rowGroups - rowMods = zipWith3 columnModifier posSpecs cMSs cMIs - rowBody = map (zipWith ($) rowMods) . rows + cMIs = fitHeaderIntoCMIs $ deriveColModInfosFromColumns' specs $ transposeRowGroups rowGroups + rowMods = zipWith3 (\p cm cmi -> (emptyFromCMI cmi, columnModifier p cm cmi)) posSpecs cMSs cMIs + + rowBody :: RowGroup a -> [[b]] + rowBody = mapRowGroupColumns rowMods colWidths = map widthCMI cMIs -- Apply modifiers to rows, adding row headers to the first row in the group if needed @@ -428,9 +432,10 @@ tableLinesBWithCMIs specs TableStyle { .. } rowHeader colHeader rowGroups = applyRowMods (Just (hSpec, r), grp) | Just rCMI <- rowHeaderCMI = zip (header rCMI) (rowBody grp) where - header cMI = map (Just . headerCellModifier hSpec noCutMark cMI) $ r : repeat emptyCell + header cMI = fmap Just $ headerCellModifier hSpec noCutMark cMI r : repeat (emptyFromCMI cMI) applyRowMods (_, grp) = map (Nothing,) $ rowBody grp + -- | A version of 'tableLinesB' specialised to produce 'String's. tableLines :: (Cell a, Cell r, Cell c) => [ColSpec] diff --git a/src/Text/Layout/Table/Cell.hs b/src/Text/Layout/Table/Cell.hs index 1c28972..2d903c7 100644 --- a/src/Text/Layout/Table/Cell.hs +++ b/src/Text/Layout/Table/Cell.hs @@ -57,10 +57,6 @@ class Cell a where -- the predicate matches. measureAlignment :: (Char -> Bool) -> a -> AlignInfo - -- | Create an empty cell. - -- This should satisfy `buildCell emptyCell = mempty`. - emptyCell :: a - -- | Insert the contents into a 'StringBuilder'. buildCell :: StringBuilder b => a -> b buildCell = buildCellView . pure @@ -73,7 +69,7 @@ class Cell a where -- instance. buildCellView :: StringBuilder b => CellView a -> b - {-# MINIMAL visibleLength, measureAlignment, emptyCell, buildCellView #-} + {-# MINIMAL visibleLength, measureAlignment, buildCellView #-} instance Cell a => Cell (CellView a) where visibleLength (CellView a l r) = visibleLength a + l + r @@ -86,7 +82,6 @@ instance Cell a => Cell (CellView a) where Just matchRemaining -> AlignInfo (matchAt + l) (Just $ matchRemaining + r) where AlignInfo matchAt mMatchRemaining = measureAlignment f a - emptyCell = pure emptyCell buildCell = buildCellView buildCellView = buildCellView . join @@ -95,12 +90,10 @@ instance Cell a => Cell (Maybe a) where measureAlignment p = maybe mempty (measureAlignment p) buildCell = maybe mempty buildCell buildCellView (CellView a l r) = maybe (spacesB $ l + r) (buildCellView . adjustCell l r) a - emptyCell = Nothing instance (Cell a, Cell b) => Cell (Either a b) where 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 @@ -112,7 +105,7 @@ instance Cell String where (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) @@ -122,7 +115,7 @@ instance Cell T.Text where (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 diff --git a/src/Text/Layout/Table/Cell/Formatted.hs b/src/Text/Layout/Table/Cell/Formatted.hs index c78c7f3..6876087 100644 --- a/src/Text/Layout/Table/Cell/Formatted.hs +++ b/src/Text/Layout/Table/Cell/Formatted.hs @@ -84,7 +84,6 @@ instance Monoid (Formatted a) where instance Cell a => Cell (Formatted a) where visibleLength = sum . fmap visibleLength measureAlignment p = foldl' (mergeAlign p) mempty - emptyCell = plain emptyCell buildCell = buildFormatted buildCell buildCellView = buildCellViewHelper (buildFormatted buildCell) diff --git a/src/Text/Layout/Table/Cell/WideString.hs b/src/Text/Layout/Table/Cell/WideString.hs index 14cae3b..864e88c 100644 --- a/src/Text/Layout/Table/Cell/WideString.hs +++ b/src/Text/Layout/Table/Cell/WideString.hs @@ -20,7 +20,6 @@ newtype WideString = WideString String instance Cell WideString where 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) @@ -55,7 +54,6 @@ newtype WideText = WideText T.Text instance Cell WideText where 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) diff --git a/src/Text/Layout/Table/Primitives/ColumnModifier.hs b/src/Text/Layout/Table/Primitives/ColumnModifier.hs index 9d910ee..fc7d602 100644 --- a/src/Text/Layout/Table/Primitives/ColumnModifier.hs +++ b/src/Text/Layout/Table/Primitives/ColumnModifier.hs @@ -3,6 +3,7 @@ module Text.Layout.Table.Primitives.ColumnModifier where import Control.Arrow ((&&&)) import Data.List +import Data.Semigroup (Max(..)) import Text.Layout.Table.Cell import Text.Layout.Table.Primitives.AlignInfo @@ -96,15 +97,25 @@ columnModifier pos cms colModInfo = case colModInfo of -- | Derive the 'ColModInfo' for each column of a list of rows by using the -- corresponding specifications. See 'deriveColModInfoFromColumn' for details. deriveColModInfos :: Cell a => [(LenSpec, AlignSpec)] -> [Row a] -> [ColModInfo] -deriveColModInfos specs = zipWith ($) (fmap deriveColModInfoFromColumn specs) . transpose +deriveColModInfos specs = deriveColModInfosFromColumns specs . transpose + +deriveColModInfos' :: Cell a => [ColSpec] -> [Row a] -> [ColModInfo] +deriveColModInfos' = deriveColModInfos . fmap (lenSpec &&& alignSpec) + +deriveColModInfosFromColumns :: (Foldable col, Cell a) => [(LenSpec, AlignSpec)] -> [col a] -> [ColModInfo] +deriveColModInfosFromColumns specs = zipWith ($) (fmap deriveColModInfoFromColumn specs) + +-- | Generate the 'AlignInfo' of a cell by using the 'OccSpec'. +deriveAlignInfo :: Cell a => OccSpec -> a -> AlignInfo +deriveAlignInfo occSpec = measureAlignment (predicate occSpec) -- | Derive the 'ColModInfo' of a single column by using the 'LenSpec' and the -- 'AlignSpec'. -deriveColModInfoFromColumn :: Cell a => (LenSpec, AlignSpec) -> Col a -> ColModInfo +deriveColModInfoFromColumn :: (Foldable col, Cell a) => (LenSpec, AlignSpec) -> col a -> ColModInfo deriveColModInfoFromColumn (lenS, alignS) = case alignS of NoAlign -> let expandFun = FillTo fixedFun i = const $ FitTo i Nothing - measureMaximumWidth = maximum . map visibleLength + measureMaximumWidth = getMax . foldMap (Max . visibleLength) lengthFun = id in go expandFun fixedFun measureMaximumWidth lengthFun @@ -114,12 +125,12 @@ deriveColModInfoFromColumn (lenS, alignS) = case alignS of lengthFun = widthAI in go expandFun fixedFun measureMaximumWidth lengthFun where - go :: forall a w. Cell a + go :: forall a w col. (Cell a, Foldable col) => (w -> ColModInfo) -> (Int -> w -> ColModInfo) - -> (Col a -> w) + -> (col a -> w) -> (w -> Int) - -> Col a + -> col a -> ColModInfo go expandFun fixedFun measureMaximumWidth lengthFun = let expandBetween' i j widthInfo | lengthFun widthInfo > j = fixedFun j widthInfo @@ -136,8 +147,8 @@ deriveColModInfoFromColumn (lenS, alignS) = case alignS of ExpandBetween i j -> expandBetween' i j in interpretLenSpec . measureMaximumWidth -deriveColModInfos' :: Cell a => [ColSpec] -> [Row a] -> [ColModInfo] -deriveColModInfos' = deriveColModInfos . fmap (lenSpec &&& alignSpec) +deriveColModInfosFromColumns' :: (Foldable col, Cell a) => [ColSpec] -> [col a] -> [ColModInfo] +deriveColModInfosFromColumns' = deriveColModInfosFromColumns . fmap (lenSpec &&& alignSpec) -- | Derive the 'ColModInfo' and generate functions without any intermediate -- steps. @@ -151,7 +162,3 @@ deriveColMods specs tab = where cmis = deriveColModInfos' specs tab --- | Generate the 'AlignInfo' of a cell by using the 'OccSpec'. -deriveAlignInfo :: Cell a => OccSpec -> a -> AlignInfo -deriveAlignInfo occSpec = measureAlignment (predicate occSpec) - diff --git a/src/Text/Layout/Table/Spec/RowGroup.hs b/src/Text/Layout/Table/Spec/RowGroup.hs index ff26ff8..c24f92a 100644 --- a/src/Text/Layout/Table/Spec/RowGroup.hs +++ b/src/Text/Layout/Table/Spec/RowGroup.hs @@ -1,18 +1,66 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} module Text.Layout.Table.Spec.RowGroup where import Text.Layout.Table.Spec.Util +import Data.List (transpose) +import Data.Functor (void) + -- | Groups rows together which should not be visually seperated from each other. -newtype RowGroup a - = RowGroup - { rows :: [Row a] - } +data RowGroup a + = SingletonRowGroup (Row a) + | MultiRowGroup [Row a] + | NullableRowGroup [Row (Maybe a)] -- | Group the given rows together. rowsG :: [Row a] -> RowGroup a -rowsG = RowGroup +rowsG = MultiRowGroup -- | Make a group of a single row. rowG :: Row a -> RowGroup a -rowG = RowGroup . (: []) +rowG = SingletonRowGroup + +-- | Provide a 'RowGroup' where single cells may be missing. +nullableRowsG :: [Row (Maybe a)] -> RowGroup a +nullableRowsG = NullableRowGroup + +-- | Extracts the shape of the 'RowGroup' from the first row. +rowGroupShape :: RowGroup a -> [()] +rowGroupShape rg = case rg of + SingletonRowGroup r -> void r + MultiRowGroup rs -> firstSubListShape rs + NullableRowGroup ors -> firstSubListShape ors + where + firstSubListShape l = case l of + r : _ -> void r + [] -> [] + +data ColumnSegment a + = SingleValueSegment a + | ColumnSegment (Col a) + | NullableColumnSegment (Col (Maybe a)) + deriving (Functor, Foldable, Eq, Show) + +newtype SegmentedColumn a = SegmentedColumn [ColumnSegment a] deriving (Functor, Foldable, Eq, Show) + +-- | Break down several 'RowGroups', which conceptually form a column by +-- themselves, into a list of columns. +transposeRowGroups :: Col (RowGroup a) -> [SegmentedColumn a] +transposeRowGroups = fmap SegmentedColumn . transpose . map transposeRowGroup + where + transposeRowGroup :: RowGroup a -> [ColumnSegment a] + transposeRowGroup rg = case rg of + SingletonRowGroup row -> SingleValueSegment <$> row + MultiRowGroup rows -> ColumnSegment <$> transpose rows + NullableRowGroup rows -> NullableColumnSegment <$> transpose rows +-- | Map each column with the corresponding function and replace empty inputs +-- with the given value. +mapRowGroupColumns :: [(b, (a -> b))] -> RowGroup a -> [[b]] +mapRowGroupColumns mappers rg = case rg of + SingletonRowGroup row -> pure $ zipWith snd mappers row + MultiRowGroup rows -> mapGrid snd rows + NullableRowGroup orows -> mapGrid (uncurry maybe) orows + where + mapGrid applyMapper = map $ zipWith applyMapper mappers diff --git a/src/Text/Layout/Table/Vertical.hs b/src/Text/Layout/Table/Vertical.hs index 6dbc66f..12dc5ec 100644 --- a/src/Text/Layout/Table/Vertical.hs +++ b/src/Text/Layout/Table/Vertical.hs @@ -18,21 +18,21 @@ import Text.Layout.Table.Primitives.Basic {- | Merges multiple columns together to a valid grid without holes. For example: >>> colsAsRowsAll top [justifyText 10 "This text will not fit on one line.", ["42", "23"]] -[["This text","42"],["will not","23"],["fit on one",""],["line.",""]] +[[Just "This text",Just "42"],[Just "will not",Just "23"],[Just "fit on one",Nothing],[Just "line.",Nothing]] The result is intended to be used with a grid layout function like 'Text.Layout.Table.grid'. -} -colsAsRowsAll :: Cell a => Position V -> [Col a] -> [Row a] -colsAsRowsAll ps = transpose . vPadAll emptyCell ps +colsAsRowsAll :: Position V -> [Col a] -> [Row (Maybe a)] +colsAsRowsAll p = transpose . vPadAll Nothing p . fmap (fmap Just) {- | Works like 'colsAsRowsAll' but every position can be specified on its own: >>> colsAsRows [top, center, bottom] [["a1"], ["b1", "b2", "b3"], ["c3"]] -[["a1","b1",""],["","b2",""],["","b3","c3"]] +[[Just "a1",Just "b1",Nothing],[Nothing,Just "b2",Nothing],[Nothing,Just "b3",Just "c3"]] -} -colsAsRows :: Cell a => [Position V] -> [Col a] -> [Row a] -colsAsRows ps = transpose . vPad emptyCell ps +colsAsRows :: [Position V] -> [Col a] -> [Row (Maybe a)] +colsAsRows ps = transpose . vPad Nothing ps . fmap (fmap Just) -- | Fill all columns to the same length by aligning at the given position. vPadAll :: a -> Position V -> [Col a] -> [Col a] diff --git a/test-suite/TestSpec.hs b/test-suite/TestSpec.hs index 704b190..69bc48e 100644 --- a/test-suite/TestSpec.hs +++ b/test-suite/TestSpec.hs @@ -20,6 +20,7 @@ import Text.Layout.Table.Spec.AlignSpec import Text.Layout.Table.Spec.CutMark import Text.Layout.Table.Spec.OccSpec import Text.Layout.Table.Spec.Position +import Text.Layout.Table.Spec.RowGroup import Text.Layout.Table.Primitives.Basic import Text.Layout.Table.Primitives.AlignInfo import Text.Layout.Table.Justify @@ -331,6 +332,35 @@ 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 "row groups" $ do + describe "rowGroupShape" $ do + it "multi" $ rowGroupShape (MultiRowGroup [[0, 1], [2, 3]]) `shouldBe` [(), ()] + it "multi only first row 1" $ rowGroupShape (MultiRowGroup [[0, 1], [2, 3, 4]]) `shouldBe` [(), ()] + it "multi only first row 2" $ rowGroupShape (MultiRowGroup [[0, 1], []]) `shouldBe` [(), ()] + it "multi empty" $ rowGroupShape (MultiRowGroup []) `shouldBe` [] + it "singleton empty" $ rowGroupShape (SingletonRowGroup []) `shouldBe` [] + it "singleton" $ rowGroupShape (SingletonRowGroup [1, 2]) `shouldBe` [(), ()] + it "nullable empty" $ rowGroupShape (NullableRowGroup []) `shouldBe` [] + it "nullable one element" $ rowGroupShape (NullableRowGroup [[Just 4]]) `shouldBe` [()] + it "nullable but no null" $ rowGroupShape (NullableRowGroup [[Just 1, Just 2]]) `shouldBe` [(), ()] + it "nullable mixed" $ rowGroupShape (NullableRowGroup [[Just 1, Nothing, Nothing]]) `shouldBe` [(), (), ()] + + let rgs = [rg1, rg2, rg3] :: [RowGroup Int] + rg1 = MultiRowGroup [[0, 1, 2], [3, 4, 5]] + rg2 = SingletonRowGroup [6, 7, 8] + rg3 = NullableRowGroup [[Nothing, Just 9, Nothing]] + it "transposeRowGroups" $ + transposeRowGroups rgs `shouldBe` [ SegmentedColumn [ColumnSegment [0, 3], SingleValueSegment 6, NullableColumnSegment [Nothing]] + , SegmentedColumn [ColumnSegment [1, 4], SingleValueSegment 7, NullableColumnSegment [Just 9]] + , SegmentedColumn [ColumnSegment [2, 5], SingleValueSegment 8, NullableColumnSegment [Nothing]] + ] + describe "mapRowGroupColumns" $ do + let mappers = [(negate 1, (+ 1)), (0, (* 2)), (negate 2, (`div` 2))] + it "multi" $ mapRowGroupColumns mappers rg1 `shouldBe` [[1, 2, 1], [4, 8, 2]] + it "singleton" $ mapRowGroupColumns mappers rg2 `shouldBe` [[7, 14, 4]] + it "nullable" $ mapRowGroupColumns mappers rg3 `shouldBe` [[negate 1, 18, negate 2]] + where customCM = doubleCutMark "<.." "..>" unevenCM = doubleCutMark "<" "-->"