Remove emptyCell (#45)

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,21 +416,26 @@ 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
     applyRowMods  :: (Maybe (HeaderColSpec, r), RowGroup a) -> [(Maybe b, [b])]
     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]

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
 

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)

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)

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)
-

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

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]

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 "<" "-->"