-- | This module provides tools to layout text as grid or table. Besides basic -- things like specifying column positioning, alignment on the same character -- and length restriction it also provides advanced features like justifying -- text and fancy tables with styling support. -- {-# LANGUAGE RecordWildCards #-} module Text.Layout.Table ( -- * Layout combinators -- | Specify how a column is rendered with the combinators in this -- section. Sensible default values are provided with 'def'. module Data.Default.Class -- ** Columns , ColSpec , column , numCol , fixedCol , fixedLeftCol -- ** Length of columns , LenSpec , expand , fixed , expandUntil , fixedUntil -- ** Positional alignment , Position , H , left , right , center -- ** Alignment of cells at characters , AlignSpec , noAlign , charAlign , predAlign , dotAlign -- ** Cut marks , CutMark , noCutMark , singleCutMark , doubleCutMark -- * Basic grid layout , Row , grid , gridLines , gridString -- * Grid modification functions , altLines , checkeredCells -- * Table layout -- ** Grouping rows , RowGroup , rowsG , rowG , colsG , colsAllG -- ** Headers , HeaderColSpec , headerColumn , Header , fullH , titlesH -- ** Layout , tableLines , tableString -- * Text justification -- $justify , justify , justifyText -- * Vertical column positioning , Col , colsAsRowsAll , colsAsRows , top , bottom , V -- * Table styles , module Text.Layout.Table.Style -- * Column modification functions , pad , trimOrPad , align , alignFixed -- * Column modifaction primitives -- | Render your own kind of tables with the following functions. , ColModInfo , widthCMI , unalignedCMI , ensureWidthCMI , ensureWidthOfCMI , columnModifier , AlignInfo , widthAI , deriveColModInfos , deriveAlignInfo , OccSpec ) where -- TODO AlignSpec: multiple alignment points - useful? -- TODO RowGroup: optional: vertical group labels -- TODO RowGroup: optional: provide extra layout for a RowGroup -- TODO ColModInfo: provide a special version of ensureWidthOfCMI to force header visibility -- TODO ColSpec: add some kind of combinator to construct ColSpec values (e.g. via Monoid, see optparse-applicative) import qualified Control.Arrow as A import Data.List import Data.Maybe import Data.Default.Class import Data.Default.Instances.Base () import Text.Layout.Table.Justify import Text.Layout.Table.Style import Text.Layout.Table.Position.Internal import Text.Layout.Table.Primitives.AlignSpec.Internal import Text.Layout.Table.Primitives.Basic import Text.Layout.Table.Primitives.Column import Text.Layout.Table.Primitives.LenSpec.Internal import Text.Layout.Table.Primitives.Occurence import Text.Layout.Table.Internal import Text.Layout.Table.Vertical ------------------------------------------------------------------------------- -- Layout types and combinators ------------------------------------------------------------------------------- -- | Align all text at the first dot from the left. This is most useful for -- floating point numbers. dotAlign :: AlignSpec dotAlign = charAlign '.' -- | Numbers are positioned on the right and aligned on the floating point dot. numCol :: ColSpec numCol = column def right dotAlign def -- | Fixes the column length and positions according to the given 'Position'. fixedCol :: Int -> Position H -> ColSpec fixedCol l pS = column (fixed l) pS def def -- | Fixes the column length and positions on the left. fixedLeftCol :: Int -> ColSpec fixedLeftCol i = fixedCol i left ------------------------------------------------------------------------------- -- Single-cell layout functions. ------------------------------------------------------------------------------- -- | Assume the given length is greater or equal than the length of the 'String' -- passed. Pads the given 'String' accordingly using the position specification. -- -- >>> pad left 10 "foo" -- "foo " -- pad :: Position o -> Int -> String -> String pad p = case p of Start -> fillRight Center -> fillCenter End -> fillLeft -- | If the given text is too long, the 'String' will be shortened according to -- the position specification. Adds cut marks to indicate that the column has -- been trimmed in length, otherwise it behaves like 'pad'. -- -- >>> trimOrPad left (singleCutMark "..") 10 "A longer text." -- "A longer.." -- trimOrPad :: Position o -> CutMark -> Int -> String -> String trimOrPad p = case p of Start -> fitRightWith Center -> fitCenterWith End -> fitLeftWith -- | Align a 'String' by first locating the position to align with and then -- padding on both sides. If no such position is found, it will align it such -- that it gets aligned before that position. -- -- >>> let { os = predOccSpec (== '.') ; ai = deriveAlignInfo os "iiii.fff" } in align os ai <$> ["1.5", "30", ".25"] -- [" 1.5 "," 30 "," .25 "] -- -- This function assumes that the given 'String' fits the 'AlignInfo'. Thus: -- -- > ai <> deriveAlignInfo s = ai -- align :: OccSpec -> AlignInfo -> String -> String align oS (AlignInfo l r) s = case splitAtOcc oS s of (ls, rs) -> fillLeft l ls ++ case rs of -- No alignment character found. [] -> spaces r _ -> fillRight r rs -- | Aligns a 'String' using a fixed width, fitting it to the width by either -- filling or cutting while respecting the alignment. alignFixed :: Position o -> CutMark -> Int -> OccSpec -> AlignInfo -> String -> String alignFixed _ cms 0 _ _ _ = "" alignFixed _ cms 1 _ _ s@(_ : (_ : _)) = applyMarkLeftWith cms " " alignFixed p cms i oS ai@(AlignInfo l r) s = let n = l + r - i in case splitAtOcc oS s of (ls, rs) -> case p of Start -> let remRight = r - n in if remRight < 0 then fitRight (l + remRight) $ fillLeft l ls else fitRight (l + remRight) $ fillLeft l ls ++ rs End -> let remLeft = l - n in if remLeft < 0 then fitLeft (r + remLeft) $ fillRight r rs else fitLeft (r + remLeft) $ ls ++ fillRight r rs Center -> {- This is really complicated, maybe there can be found something better. First case l > r: l |<----'----->| |<-----------x----->| |--.-->| r c1 = (l + r) div 2 | |<---'--->|<---.--->| . | . c2 = c1 + (l + r) mod 2 . . d2 = d1 + i mod 2 . | |<-.->|<-'-->| | d1 = i div 2 |<----.----->| i needed length on the left side: l - c1 + d1 needed length on the right side: d2 - (l - c1) Second case l < r: l |<--'-->| |<------x---------->| |<----.---->| r c1 = (l + r) div 2 | |<---'--->|<---.--->| . | . c2 = c1 + (l + r) mod 2 . . d2 = d1 + i mod 2 . | |<-.->|<-'-->| | d1 = i div 2 |<----.----->| i needed length on the left side: d1 - (r - c2) needed length on the right side: (c1 - l) + d2 -} let (c, remC) = (l + r) `divMod` 2 (d, remD) = i `divMod` 2 d2 = d + remD c2 = c + remC -- Note: widthL and widthR can be negative if there is no -- width left and we need to further trim into the other -- side. (widthL, widthR) = if l > c then (l - c2 + d, d2 - (l - c2)) else (d - (r - c), (c2 - l) + d2) lenL = length ls lenR = length rs toCutLfromR = negate $ min 0 widthL toCutRfromL = max 0 $ negate widthR (markL, funL) = if lenL > widthL then ( applyMarkLeft , take (widthL - toCutRfromL) . drop (lenL - widthL) ) else ( id , fillLeft (widthL - toCutRfromL) . take (lenL - toCutRfromL) ) (markR, funR) = if lenR > widthR then (applyMarkRight, take widthR) else (id , fillRight widthR) in markL $ markR $ funL ls ++ drop toCutLfromR (funR rs) where fitRight = fitRightWith cms fitLeft = fitLeftWith cms applyMarkRight = applyMarkRightWith cms applyMarkLeft = applyMarkLeftWith cms -- | Specifies how a column should be modified. Values of this type are derived -- in a traversal over the input columns by using 'deriveColModInfos'. Finally, -- 'columnModifier' will interpret them and apply the appropriate modification -- function to the cells of the column. data ColModInfo = FillAligned OccSpec AlignInfo | FillTo Int | FitTo Int (Maybe (OccSpec, AlignInfo)) -- | Private show function. showCMI :: ColModInfo -> String showCMI cmi = case cmi of FillAligned oS ai -> "FillAligned .. " ++ showAI ai FillTo i -> "FillTo " ++ show i FitTo i _ -> "FitTo " ++ show i ++ ".." -- | Get the exact width of a 'ColModInfo' after applying it with -- 'columnModifier'. widthCMI :: ColModInfo -> Int widthCMI cmi = case cmi of FillAligned _ ai -> widthAI ai FillTo maxLen -> maxLen FitTo lim _ -> lim -- | Remove alignment from a 'ColModInfo'. This is used to change alignment of -- headers while using the combined width information. unalignedCMI :: ColModInfo -> ColModInfo unalignedCMI cmi = case cmi of FillAligned _ ai -> FillTo $ widthAI ai FitTo i _ -> FitTo i Nothing _ -> cmi -- | Ensures that the modification provides a minimum width but only if it is -- not limited. ensureWidthCMI :: Int -> Position H -> ColModInfo -> ColModInfo ensureWidthCMI w pos cmi = case cmi of FillAligned oS ai@(AlignInfo lw rw) -> let neededW = w - widthAI ai in if neededW <= 0 then cmi else FillAligned oS $ case pos of Start -> AlignInfo lw (rw + neededW) End -> AlignInfo (lw + neededW) rw Center -> let (q, r) = neededW `divMod` 2 in AlignInfo (q + lw) (q + rw + r) FillTo maxLen -> FillTo (max maxLen w) _ -> cmi -- | Ensures that the given 'String' will fit into the modified columns. ensureWidthOfCMI :: String -> Position H -> ColModInfo -> ColModInfo ensureWidthOfCMI = ensureWidthCMI . length -- | Generates a function which modifies a given 'String' according to -- 'Text.Layout.Table.Position.Position', 'CutMark' and 'ColModInfo'. columnModifier :: Position H -> CutMark -> ColModInfo -> (String -> String) columnModifier pos cms lenInfo = case lenInfo of FillAligned oS ai -> align oS ai FillTo maxLen -> pad pos maxLen FitTo lim mT -> maybe (trimOrPad pos cms lim) (uncurry $ alignFixed pos cms lim) mT -- TODO factor out -- | Specifies the length before and after an alignment position (including the -- alignment character). data AlignInfo = AlignInfo Int Int -- | Private show function. showAI :: AlignInfo -> String showAI (AlignInfo l r) = "AlignInfo " ++ show l ++ " " ++ show r -- | The column width when using the 'AlignInfo'. widthAI :: AlignInfo -> Int widthAI (AlignInfo l r) = l + r -- | Produce an 'AlignInfo' that is wide enough to hold inputs of both given -- 'AlignInfo's. instance Monoid AlignInfo where mempty = AlignInfo 0 0 mappend (AlignInfo ll lr) (AlignInfo rl rr) = AlignInfo (max ll rl) (max lr rr) -- | Derive the 'ColModInfo' by using layout specifications and the actual cells -- of a column. deriveColModInfos :: [(LenSpec, AlignSpec)] -> [Row String] -> [ColModInfo] deriveColModInfos specs = zipWith ($) (fmap fSel specs) . transpose where fSel (lenSpec, alignSpec) = case alignSpec of NoAlign -> let fitTo i = const $ FitTo i Nothing expandUntil f i max = if f (max <= i) then FillTo max else fitTo i max fun = case lenSpec of Expand -> FillTo Fixed i -> fitTo i ExpandUntil i -> expandUntil id i FixedUntil i -> expandUntil not i in fun . maximum . map length AlignOcc oS -> let fitToAligned i = FitTo i . Just . (,) oS fillAligned = FillAligned oS expandUntil f i ai = if f (widthAI ai <= i) then fillAligned ai else fitToAligned i ai fun = case lenSpec of Expand -> fillAligned Fixed i -> fitToAligned i ExpandUntil i -> expandUntil id i FixedUntil i -> expandUntil not i in fun . foldMap (deriveAlignInfo oS) -- | Generate the 'AlignInfo' of a cell by using the 'OccSpec'. deriveAlignInfo :: OccSpec -> String -> AlignInfo deriveAlignInfo occSpec s = AlignInfo <$> length . fst <*> length . snd $ splitAtOcc occSpec s ------------------------------------------------------------------------------- -- Basic layout ------------------------------------------------------------------------------- -- | Modifies cells according to the column specification. grid :: [ColSpec] -> [Row String] -> [Row String] grid specs tab = zipWith ($) cmfs <$> tab where -- | The column modification function for each column. cmfs = zipWith (uncurry columnModifier) (map (position A.&&& cutMark) specs) cmis cmis = deriveColModInfos (map (lenSpec A.&&& alignSpec) specs) tab -- | Behaves like 'grid' but produces lines by joining with whitespace. gridLines :: [ColSpec] -> [Row String] -> [String] gridLines specs = fmap unwords . grid specs -- | Behaves like 'gridLines' but produces a string by joining with the newline -- character. gridString :: [ColSpec] -> [Row String] -> String gridString specs = concatLines . gridLines specs ------------------------------------------------------------------------------- -- Grid modification functions ------------------------------------------------------------------------------- -- | Applies functions to given lines in a alternating fashion. This makes it -- easy to color lines to improve readability in a row. altLines :: [a -> b] -> [a] -> [b] altLines = zipWith ($) . cycle -- | Applies functions to cells in a alternating fashion for every line, every -- other line gets shifted by one. This is useful for distinguishability of -- single cells in a grid arrangement. checkeredCells :: (a -> b) -> (a -> b) -> [[a]] -> [[b]] checkeredCells f g = zipWith altLines $ cycle [[f, g], [g, f]] ------------------------------------------------------------------------------- -- Advanced layout ------------------------------------------------------------------------------- -- | Create a 'RowGroup' by aligning the columns vertically. The position is -- specified for each column. colsG :: [Position V] -> [Col String] -> RowGroup colsG ps = rowsG . colsAsRows ps -- | Create a 'RowGroup' by aligning the columns vertically. Each column uses -- the same vertical positioning. colsAllG :: Position V -> [Col String] -> RowGroup colsAllG p = rowsG . colsAsRowsAll p -- | Specifies a header. data Header = Header [HeaderColSpec] [String] | NoHeader -- | No header is used by default. instance Default Header where def = NoHeader -- | Specify a header column for every title. fullH :: [HeaderColSpec] -> [String] -> Header fullH = Header -- | Use titles with the default header column specification. titlesH :: [String] -> Header titlesH = fullH $ repeat def -- | Layouts a good-looking table with an optional header. Note that specifying -- fewer layout specifications than columns or vice versa will result in not -- showing the redundant ones. tableLines :: [ColSpec] -- ^ Layout specification of columns -> TableStyle -- ^ Visual table style -> Header -- ^ Optional header details -> [RowGroup] -- ^ Rows which form a cell together -> [String] tableLines specs TableStyle { .. } header rGs = topLine : addHeaderLines (rowGroupLines ++ [bottomLine]) where -- Helpers for horizontal lines hLine hS d = hLineDetail hS d d d hLineDetail hS dL d dR cols = intercalate [hS] $ [dL] : intersperse [d] cols ++ [[dR]] -- Spacers consisting of columns of seperator elements. genHSpacers c = map (`replicate` c) colWidths -- Horizontal seperator lines topLine = hLineDetail realTopH realTopL realTopC realTopR $ genHSpacers realTopH bottomLine = hLineDetail groupBottomH groupBottomL groupBottomC groupBottomR $ genHSpacers groupBottomH groupSepLine = hLineDetail groupSepH groupSepLC groupSepC groupSepRC $ genHSpacers groupSepH headerSepLine = hLineDetail headerSepH headerSepLC headerSepC headerSepRC $ genHSpacers headerSepH -- Vertical content lines rowGroupLines = intercalate [groupSepLine] $ map (map (hLine ' ' groupV) . applyRowMods . rows) rGs -- Optional values for the header (addHeaderLines, fitHeaderIntoCMIs, realTopH, realTopL, realTopC, realTopR) = case header of Header headerColSpecs hTitles -> let headerLine = hLine ' ' headerV (zipWith ($) headerRowMods hTitles) headerRowMods = zipWith3 (\(HeaderColSpec pos optCutMark) cutMark -> columnModifier pos $ fromMaybe cutMark optCutMark ) headerColSpecs cMSs (map unalignedCMI cMIs) in ( (headerLine :) . (headerSepLine :) , zipWith ($) $ zipWith ($) (map ensureWidthOfCMI hTitles) posSpecs , headerTopH , headerTopL , headerTopC , headerTopR ) NoHeader -> ( id , id , groupTopH , groupTopL , groupTopC , groupTopR ) cMSs = map cutMark specs posSpecs = map position specs applyRowMods = map (zipWith ($) rowMods) rowMods = zipWith3 columnModifier posSpecs cMSs cMIs cMIs = fitHeaderIntoCMIs $ deriveColModInfos (map (lenSpec A.&&& alignSpec) specs) $ concatMap rows rGs colWidths = map widthCMI cMIs -- | Does the same as 'tableLines', but concatenates lines. tableString :: [ColSpec] -- ^ Layout specification of columns -> TableStyle -- ^ Visual table style -> Header -- ^ Optional header details -> [RowGroup] -- ^ Rows which form a cell together -> String tableString specs style header rGs = concatLines $ tableLines specs style header rGs ------------------------------------------------------------------------------- -- Text justification ------------------------------------------------------------------------------- -- $justify -- Text can easily be justified and distributed over multiple lines. Such -- columns can easily be combined with other columns.