diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2016, Moritz Bruder + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Moritz Bruder nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Test.hs b/src/Test.hs new file mode 100644 --- /dev/null +++ b/src/Test.hs @@ -0,0 +1,34 @@ +module Main where + +import Control.Monad + +import Text.Layout.Table + +main :: IO () +main = + forM_ styles $ \style -> + forM_ layouts $ \layout -> (putStrLn "" >>) $ (print layout >>) $ mapM_ putStrLn $ + layoutTableToLines [ rowGroup [ [longText, smallNum] + , [shortText, bigNum] + ] + ] + (Just (["Some text", "Some numbers"], repeat centerHL)) + [layout, layout] + style + where + longText = "This is long text" + shortText = "Short" + bigNum = "200300400500600.2" + smallNum = "4.20000000" + styles = [ asciiRoundS + , unicodeS + , unicodeRoundS + , unicodeBoldS + , unicodeBoldStripedS + , unicodeBoldHeaderS + ] + layouts = [ LayoutSpec l p a ellipsisCutMark + | l <- [Expand, Fixed 10] + , p <- [LeftPos, RightPos, CenterPos] + , a <- [NoAlign, AlignAtChar $ OccSpec '.' 0] + ] diff --git a/src/Text/Layout/Table.hs b/src/Text/Layout/Table.hs new file mode 100644 --- /dev/null +++ b/src/Text/Layout/Table.hs @@ -0,0 +1,502 @@ +-- | 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. +-- +-- == Some examples +-- Layouting text as a plain grid: +-- +-- >>> putStrLn $ layoutToString [["a", "b"], ["c", "d"]] (repeat defaultL) +-- a b +-- c d +-- +-- Fancy table without header: +-- +-- >>> putStrLn $ layoutTableToString [rowGroup [["Jack", "184.74"]], rowGroup [["Jane", "162.2"]]] Nothing [defaultL, numL] unicodeRoundS +-- ╭──────┬────────╮ +-- │ Jack │ 184.74 │ +-- ├──────┼────────┤ +-- │ Jane │ 162.2 │ +-- ╰──────┴────────╯ +-- +-- Fancy table with header: +-- +-- >>> putStrLn $ layoutTableToString [ rowGroup [["A very long text", "0.42000000"]] +-- , rowGroup [["Short text", "100200.5"]] +-- ] +-- (Just (["Title", "Length"], repeat centerHL)) +-- [ limitLeftL 20 +-- , LayoutSpec (Fixed 10) +-- CenterPos +-- dotAlign +-- shortCutMark +-- ] +-- unicodeRoundS +-- ╭──────────────────────┬────────────╮ +-- │ Title │ Length │ +-- ╞══════════════════════╪════════════╡ +-- │ A very long text │ 0.4200… │ +-- ├──────────────────────┼────────────┤ +-- │ Short text │ …200.5 │ +-- ╰──────────────────────┴────────────╯ +-- +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE MultiWayIf #-} +module Text.Layout.Table + ( -- * Layout types and combinators + -- $layout + LayoutSpec(..) + , defaultL + , numL + , limitL + , limitLeftL + , LenSpec(..) + , PosSpec(..) + , AlignSpec(..) + , dotAlign + , OccSpec(..) + , CutMarkSpec + , defaultCutMark + , ellipsisCutMark + , noCutMark + , singleCutMark + , cutMark + + -- * Basic grid and table layout + , layoutToCells + , layoutToLines + , layoutToString + + -- * Grid modification functions + , altLines + , checkeredCells + + -- * Advanced table layout + , RowGroup + , rowGroup + , HeaderLayoutSpec(..) + , centerHL + , leftHL + , layoutTableToLines + , layoutTableToString + + -- * Text justification + -- $justify + , justify + , justifyText + , columnsAsGrid + , justifyTextsAsGrid + , justifyWordListsAsGrid + + -- * Table styles + , module Text.Layout.Table.Style + + -- * Column modification functions + , pad + , trimOrPad + , align + , alignFixed + + -- * Column modifaction primitives + , ColModInfo(..) + , widthCMI + , unalignedCMI + , ensureWidthCMI + , ensureWidthOfCMI + , columnModifier + , AlignInfo(..) + , widthAI + , deriveColModInfos + , deriveAlignInfo + ) 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 + +import Control.Arrow +import Data.List +import Data.Maybe + +import Text.Layout.Table.PrimMod +import Text.Layout.Table.Justify +import Text.Layout.Table.Style + +------------------------------------------------------------------------------- +-- Layout types and combinators +------------------------------------------------------------------------------- +{- $layout + Specify the layout of columns. Layout combinators have a 'L' as postfix. +-} + +-- | Determines the layout of a column. +data LayoutSpec = LayoutSpec + { lenSpec :: LenSpec + , posSpec :: PosSpec + , alignSpec :: AlignSpec + , cutMarkSpec :: CutMarkSpec + } deriving Show + +-- | Determines how long a column will be. +data LenSpec = Expand | Fixed Int deriving Show + +-- | Determines how a column will be positioned. Note that on an odd number of +-- space, centering is left-biased. +data PosSpec = LeftPos | RightPos | CenterPos deriving Show + +-- | Determines whether a column will align at a specific letter. +data AlignSpec = AlignAtChar OccSpec | NoAlign deriving Show + +-- | Specifies an occurence of a letter. +data OccSpec = OccSpec Char Int deriving Show + +-- | Align all text at the dot. +dotAlign :: AlignSpec +dotAlign = AlignAtChar $ OccSpec '.' 0 + +-- | Use the same cut mark for left and right. +singleCutMark :: String -> CutMarkSpec +singleCutMark l = cutMark l (reverse l) + +-- | Default cut mark used when cutting off text. +defaultCutMark :: CutMarkSpec +defaultCutMark = singleCutMark ".." + +-- | Don't use a cut mark. +noCutMark :: CutMarkSpec +noCutMark = singleCutMark "" + +-- | A single unicode character showing three dots is used as cut mark. +ellipsisCutMark :: CutMarkSpec +ellipsisCutMark = singleCutMark "…" + +-- | The default layout will allow maximum expand and is positioned on the left. +defaultL :: LayoutSpec +defaultL = LayoutSpec Expand LeftPos NoAlign defaultCutMark + +-- | Numbers are positioned on the right and aligned on the floating point dot. +numL :: LayoutSpec +numL = LayoutSpec Expand RightPos (AlignAtChar $ OccSpec '.' 0) defaultCutMark + +-- | Limits the column length and positions according to the given 'PosSpec'. +limitL :: Int -> PosSpec -> LayoutSpec +limitL l pS = LayoutSpec (Fixed l) pS NoAlign defaultCutMark + +-- | Limits the column length and positions on the left. +limitLeftL :: Int -> LayoutSpec +limitLeftL i = limitL i LeftPos + +------------------------------------------------------------------------------- +-- 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 LeftPos 10 "foo" +-- "foo " +-- +pad :: PosSpec -> Int -> String -> String +pad p = case p of + LeftPos -> fillRight + RightPos -> fillLeft + CenterPos -> fillCenter + +-- | If the given text is too long, the 'String' will be shortened according to +-- the position specification, also adds some dots to indicate that the column +-- has been trimmed in length, otherwise behaves like 'pad'. +-- +-- >>> trimOrPad LeftPos (singleCutMark "..") 10 "A longer text." +-- "A longer.." +-- +trimOrPad :: PosSpec -> CutMarkSpec -> Int -> String -> String +trimOrPad p = case p of + LeftPos -> fitRightWith + RightPos -> fitLeftWith + CenterPos -> fitCenterWith + +-- | Align a column by first finding the position to pad with and then padding +-- the missing lengths to the maximum value. If no such position is found, it +-- will align it such that it gets aligned before that position. +-- +-- This function assumes: +-- +-- > 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. + [] -> (if r == 0 then "" else spaces r) + _ -> fillRight r rs + +-- | Aligns a column using a fixed width, fitting it to the width by either +-- filling or cutting while respecting the alignment. +alignFixed :: PosSpec -> CutMarkSpec -> 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 if n <= 0 + then pad p i $ align oS ai s + else case splitAtOcc oS s of + (ls, rs) -> case p of + LeftPos -> + let remRight = r - n + in if remRight < 0 + then fitRight (l + remRight) $ fillLeft l ls + else fillLeft l ls ++ fitRight remRight rs + RightPos -> + let remLeft = l - n + in if remLeft < 0 + then fitLeft (r + remLeft) $ fillRight r rs + else fitLeft remLeft ls ++ fillRight r rs + CenterPos -> + let (q, rem) = n `divMod` 2 + remLeft = l - q + remRight = r - q - rem + in if | remLeft < 0 -> fitLeft (remRight + remLeft) $ fitRight remRight rs + | remRight < 0 -> fitRight (remLeft + remRight) $ fitLeft remLeft ls + | remLeft == 0 -> applyMarkLeftWith cms $ fitRight remRight rs + | remRight == 0 -> applyMarkRight $ fitLeft remLeft ls + | otherwise -> fitRight (remRight + remLeft) $ fitLeft remLeft ls ++ rs + where + fitRight = fitRightWith cms + fitLeft = fitLeftWith cms + applyMarkRight = applyMarkRightWith cms + +splitAtOcc :: OccSpec -> String -> (String, String) +splitAtOcc (OccSpec c occ) = first reverse . go 0 [] + where + go n ls xs = case xs of + [] -> (ls, []) + x : xs' -> if c == x + then if n == occ + then (ls, xs) + else go (succ n) (x : ls) xs' + else go n (x : ls) xs' + +-- | Specifies how a column should be modified. +data ColModInfo = FillAligned OccSpec AlignInfo + | FillTo Int + | FitTo Int (Maybe (OccSpec, AlignInfo)) + deriving Show + +-- | Get the exact width after the modification. +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 -> PosSpec -> ColModInfo -> ColModInfo +ensureWidthCMI w posSpec cmi = case cmi of + FillAligned oS ai@(AlignInfo lw rw) -> + let neededW = widthAI ai - w + in if neededW >= 0 + then cmi + else FillAligned oS $ case posSpec of + LeftPos -> AlignInfo lw (rw + neededW) + RightPos -> AlignInfo (lw + neededW) rw + CenterPos -> 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 -> PosSpec -> ColModInfo -> ColModInfo +ensureWidthOfCMI = ensureWidthCMI . length + +-- | Generates a function which modifies a given 'String' according to +-- 'PosSpec', 'CutMarkSpec' and 'ColModInfo'. +columnModifier :: PosSpec -> CutMarkSpec -> ColModInfo -> (String -> String) +columnModifier posSpec cms lenInfo = case lenInfo of + FillAligned oS ai -> align oS ai + FillTo maxLen -> pad posSpec maxLen + FitTo lim mT -> + maybe (trimOrPad posSpec cms lim) (uncurry $ alignFixed posSpec cms lim) mT + +-- | Specifies the length before and after a letter. +data AlignInfo = AlignInfo Int Int deriving Show + +-- | The column width when using the 'AlignInfo'. +widthAI :: AlignInfo -> Int +widthAI (AlignInfo l r) = l + r + +-- | Since determining a maximum in two directions is not possible, a 'Monoid' +-- instance is provided. +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 looking at the +-- cells. +deriveColModInfos :: [(LenSpec, AlignSpec)] -> [[String]] -> [ColModInfo] +deriveColModInfos specs = zipWith ($) (fmap fSel specs) . transpose + where + fSel specs = case specs of + (Expand , NoAlign ) -> FillTo . maximum . fmap length + (Expand , AlignAtChar oS) -> FillAligned oS . deriveAlignInfos oS + (Fixed i, NoAlign ) -> const $ FitTo i Nothing + (Fixed i, AlignAtChar oS) -> FitTo i . Just . (,) oS . deriveAlignInfos oS + deriveAlignInfos = foldMap . deriveAlignInfo + +-- | Generate the 'AlignInfo' of a cell 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 given 'LayoutSpec'. +layoutToCells :: [[String]] -> [LayoutSpec] -> [[String]] +layoutToCells tab specs = zipWith apply tab + . repeat + . zipWith (uncurry columnModifier) (map (posSpec &&& cutMarkSpec) specs) + $ deriveColModInfos (map (lenSpec &&& alignSpec) specs) tab + where + apply = zipWith $ flip ($) + +-- | Behaves like 'layoutCells' but produces lines by joining with whitespace. +layoutToLines :: [[String]] -> [LayoutSpec] -> [String] +layoutToLines tab specs = map unwords $ layoutToCells tab specs + +-- | Behaves like 'layoutCells' but produces a 'String' by joining with the +-- newline character. +layoutToString :: [[String]] -> [LayoutSpec] -> String +layoutToString tab specs = intercalate "\n" $ layoutToLines tab specs + +------------------------------------------------------------------------------- +-- Grid modifier functions +------------------------------------------------------------------------------- + +-- | Applies functions alternating to given lines. This makes it easy to color +-- lines to improve readability in a row. +altLines :: [a -> b] -> [a] -> [b] +altLines = zipWith ($) . cycle + +-- | Applies functions alternating to cells 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 +------------------------------------------------------------------------------- + +-- | Groups rows together, which are not seperated from each other. +data RowGroup = RowGroup + { rows :: [[String]] + } + +-- | Construct a row group from a list of rows. +rowGroup :: [[String]] -> RowGroup +rowGroup = RowGroup + +-- | Specifies how a header is layout, by omitting the cut mark it will use the +-- one specified in the 'LayoutSpec' like the other cells in that column. +data HeaderLayoutSpec = HeaderLayoutSpec PosSpec (Maybe CutMarkSpec) + +-- | A centered header layout. +centerHL :: HeaderLayoutSpec +centerHL = HeaderLayoutSpec CenterPos Nothing + +-- | A left-positioned header layout. +leftHL :: HeaderLayoutSpec +leftHL = HeaderLayoutSpec LeftPos Nothing + +-- | Layouts a good-looking table with a optional header. Note that specifying +-- fewer layout specifications than columns or vice versa will result in not +-- showing them. +layoutTableToLines :: [RowGroup] -- ^ Groups + -> Maybe ([String], [HeaderLayoutSpec]) -- ^ Optional header details + -> [LayoutSpec] -- ^ Layout specification of columns + -> TableStyle -- ^ Visual table style + -> [String] +layoutTableToLines rGs optHeaderInfo specs (TableStyle { .. }) = + topLine : addHeaderLines (rowGroupLines ++ [bottomLine]) + where + -- Line helpers + vLine hs d = vLineDetail hs d d d + vLineDetail hS dL d dR cols = intercalate [hS] $ [dL] : intersperse [d] cols ++ [[dR]] + + -- Spacers consisting of columns of seperator elements. + genHSpacers c = map (flip replicate c) colWidths + hHeaderSpacers = genHSpacers headerSepH + hGroupSpacers = genHSpacers groupSepH + + + -- Vertical seperator lines + topLine = vLineDetail realTopH realTopL realTopC realTopR $ genHSpacers realTopH + bottomLine = vLineDetail groupBottomH groupBottomL groupBottomC groupBottomR $ genHSpacers groupBottomH + groupSepLine = groupSepLC : groupSepH : intercalate [groupSepH, groupSepC, groupSepH] hGroupSpacers ++ [groupSepH, groupSepRC] + headerSepLine = vLineDetail headerSepH headerSepLC headerSepC headerSepRC hHeaderSpacers + + -- Vertical content lines + rowGroupLines = intercalate [groupSepLine] $ map (map (vLine ' ' groupV) . applyRowMods . rows) rGs + + -- Optional values for the header + (addHeaderLines, fitHeaderIntoCMIs, realTopH, realTopL, realTopC, realTopR) = case optHeaderInfo of + Just (h, headerLayoutSpecs) -> + let headerLine = vLine ' ' headerV (zipApply h headerRowMods) + headerRowMods = zipWith3 (\(HeaderLayoutSpec posSpec optCutMarkSpec) cutMarkSpec -> + columnModifier posSpec $ fromMaybe cutMarkSpec optCutMarkSpec + ) + headerLayoutSpecs + cMSs + (map unalignedCMI cMIs) + in + ( (headerLine :) . (headerSepLine :) + , zipWith ($) $ zipWith ($) (map ensureWidthOfCMI h) posSpecs + , headerTopH + , headerTopL + , headerTopC + , headerTopR + ) + Nothing -> + ( id + , id + , groupTopH + , groupTopL + , groupTopC + , groupTopR + ) + + cMSs = map cutMarkSpec specs + posSpecs = map posSpec specs + applyRowMods xss = zipWith zipApply xss $ repeat rowMods + rowMods = zipWith3 columnModifier posSpecs cMSs cMIs + cMIs = fitHeaderIntoCMIs $ deriveColModInfos (map (lenSpec &&& alignSpec) specs) + $ concatMap rows rGs + colWidths = map widthCMI cMIs + zipApply = zipWith $ flip ($) + +layoutTableToString :: [RowGroup] + -> Maybe ([String], [HeaderLayoutSpec]) + -> [LayoutSpec] + -> TableStyle + -> String +layoutTableToString rGs optHeaderInfo specs = intercalate "\n" . layoutTableToLines rGs optHeaderInfo specs + + +------------------------------------------------------------------------------- +-- Text justification +------------------------------------------------------------------------------- + +-- $justify +-- Text can easily be justified and distributed over multiple lines. Such +-- columns can easily be combined with other columns. +-- diff --git a/src/Text/Layout/Table/Justify.hs b/src/Text/Layout/Table/Justify.hs new file mode 100644 --- /dev/null +++ b/src/Text/Layout/Table/Justify.hs @@ -0,0 +1,102 @@ +-- | Produce justified text, which is spread over multiple rows, and join it +-- with other columns. For a simple cut, 'chunksOf' from 'Data.List.Split' is +-- the way to go. +{-# LANGUAGE MultiWayIf #-} +module Text.Layout.Table.Justify + ( justifyTextsAsGrid + , justifyWordListsAsGrid + , columnsAsGrid + , fillSameLength + , justifyText + , justify + , dimorphicSummands + , dimorphicSummandsBy + ) where + +import Control.Arrow +import Data.List + +-- | Justifies texts and presents the resulting lines in a grid structure (each +-- text in one column). +justifyTextsAsGrid :: [(Int, String)] -> [[String]] +justifyTextsAsGrid = justifyWordListsAsGrid . fmap (second words) + +-- | Justifies lists of words and presents the resulting lines in a grid +-- structure (each list of words in one column). This is useful if you don't +-- want to split just at whitespaces. +justifyWordListsAsGrid :: [(Int, [String])] -> [[String]] +justifyWordListsAsGrid = columnsAsGrid . fmap (uncurry justify) + +{- | Merges multiple columns together and merges them to a valid grid without + holes. The following example clarifies this: + +>>> columnsAsGrid [justifyText 10 "This text will not fit on one line.", ["42", "23"]] +[["This text","42"],["will not","23"],["fit on one",""],["line.",""]] + +-} +columnsAsGrid :: [[[a]]] -> [[[a]]] +columnsAsGrid = transpose . fillSameLength [] + +-- | Fill all sublists to the same length. +fillSameLength :: a -> [[a]] -> [[a]] +fillSameLength x l = fmap (fillTo $ maximum $ 0 : fmap length l) l + where + fillTo i l = take i $ l ++ repeat x + +-- | Uses 'words' to split the text into words and justifies it with 'justify'. +-- +-- >>> justifyText 10 "This text will not fit on one line." +-- ["This text","will not","fit on one","line."] +-- +justifyText :: Int -> String -> [String] +justifyText w = justify w . words + +-- | Fits as many words on a line, depending on the given width. Every line, but +-- the last one, gets equally filled with spaces between the words, as far as +-- possible. +justify :: Int -> [String] -> [String] +justify width = mapInit pad (\(_, _, line) -> unwords line) . gather 0 0 [] + where + pad (len, wCount, line) = unwords $ if len < width + then zipWith (++) line $ dimorphicSpaces (width - len) (pred wCount) ++ [""] + else line + + gather lineLen wCount line ws = case ws of + [] | null line -> [] + | otherwise -> [(lineLen, wCount, reverse line)] + w : ws' -> + let wLen = length w + newLineLen = lineLen + 1 + wLen + reinit = gather wLen 1 [w] ws' + in if | null line -> reinit + | newLineLen <= width -> gather newLineLen (succ wCount) (w : line) ws' + | otherwise -> (lineLen, wCount, reverse line) : reinit + +-- | Map inits with the first function and the last one with the last function. +mapInit :: (a -> b) -> (a -> b) -> [a] -> [b] +mapInit _ _ [] = [] +mapInit f g (x : xs) = go x xs + where + go y [] = [g y] + go y (y' : ys) = f y : go y' ys + +dimorphicSpaces :: Int -> Int -> [String] +dimorphicSpaces = dimorphicSummandsBy $ flip replicate ' ' + +-- | Splits a given number into summands of 2 different values, where the +-- first one is exactly one bigger than the second one. Splitting 40 spaces +-- into 9 almost equal parts would result in: +-- +-- >>> dimorphicSummands 40 9 +-- [5,5,5,5,4,4,4,4,4] +-- +dimorphicSummands :: Int -> Int -> [Int] +dimorphicSummands = dimorphicSummandsBy id + +dimorphicSummandsBy :: (Int -> a) -> Int -> Int -> [a] +dimorphicSummandsBy _ _ 0 = [] +dimorphicSummandsBy f n splits = replicate r largeS ++ replicate (splits - r) smallS + where + (q, r) = n `divMod` splits + largeS = f $ succ q + smallS = f q diff --git a/src/Text/Layout/Table/PrimMod.hs b/src/Text/Layout/Table/PrimMod.hs new file mode 100644 --- /dev/null +++ b/src/Text/Layout/Table/PrimMod.hs @@ -0,0 +1,98 @@ +-- | This module contains primitive modifiers for 'String's to be filled or fitted to a specific length. +module Text.Layout.Table.PrimMod + ( CutMarkSpec + , cutMark + , spaces + , fillLeft' + , fillLeft + , fillRight + , fillCenter' + , fillCenter + , fitRightWith + , fitLeftWith + , fitCenterWith + , applyMarkLeftWith + , applyMarkRightWith + ) + where + +-- | Specifies how the place looks where a 'String' has been cut. Note that the +-- cut mark may be cut itself, to fit into a column. +data CutMarkSpec = CutMarkSpec + { leftMark :: String + , rightMark :: String + } + +instance Show CutMarkSpec where + show (CutMarkSpec l r) = "cutMark " ++ show l ++ ' ' : show (reverse r) + +-- | Display custom characters on a cut. +cutMark :: String -> String -> CutMarkSpec +cutMark l r = CutMarkSpec l (reverse r) + +spaces :: Int -> String +spaces = flip replicate ' ' + +fillLeft' :: Int -> Int -> String -> String +fillLeft' i lenS s = spaces (i - lenS) ++ s + +-- | Fill on the left until the 'String' has the desired length. +fillLeft :: Int -> String -> String +fillLeft i s = fillLeft' i (length s) s + +-- | Fill on the right until the 'String' has the desired length. +fillRight :: Int -> String -> String +fillRight i s = take i $ s ++ repeat ' ' + +fillCenter' :: Int -> Int -> String -> String +fillCenter' i lenS s = let missing = i - lenS + (q, r) = missing `divMod` 2 + -- Puts more spaces on the right if odd. + in spaces q ++ s ++ spaces (q + r) + +-- | Fill on both sides equally until the 'String' has the desired length. +fillCenter :: Int -> String -> String +fillCenter i s = fillCenter' i (length s) s + +-- | Fits to the given length by either trimming or filling it to the right. +fitRightWith :: CutMarkSpec -> Int -> String -> String +fitRightWith cms i s = + if length s <= i + then fillRight i s + else applyMarkRightWith cms $ take i s + --take i $ take (i - mLen) s ++ take mLen m + +-- | Fits to the given length by either trimming or filling it to the right. +fitLeftWith :: CutMarkSpec -> Int -> String -> String +fitLeftWith cms i s = + if lenS <= i + then fillLeft' i lenS s + else applyMarkLeftWith cms $ drop (lenS - i) s + where + lenS = length s + +-- | Fits to the given length by either trimming or filling it on both sides, +-- but when only 1 character should be trimmed it will trim left. +fitCenterWith :: CutMarkSpec -> Int -> String -> String +fitCenterWith cms i s = + if diff >= 0 + then fillCenter' i lenS s + else case splitAt halfLenS s of + (ls, rs) -> addMarks $ drop (halfLenS - halfI) ls ++ take (halfI + r) rs + where + addMarks = applyMarkLeftWith cms . if diff == (-1) then id else applyMarkRightWith cms + diff = i - lenS + lenS = length s + halfLenS = lenS `div` 2 + (halfI, r) = i `divMod` 2 + +-- | Applies a 'CutMarkSpec' to the left of a 'String', while preserving the length. +applyMarkLeftWith :: CutMarkSpec -> String -> String +applyMarkLeftWith cms = applyMarkLeftBy leftMark cms + +-- | Applies a 'CutMarkSpec' to the right of a 'String', while preserving the length. +applyMarkRightWith :: CutMarkSpec -> String -> String +applyMarkRightWith cms = reverse . applyMarkLeftBy rightMark cms . reverse + +applyMarkLeftBy :: (a -> String) -> a -> String -> String +applyMarkLeftBy f v = zipWith ($) $ map const (f v) ++ repeat id diff --git a/src/Text/Layout/Table/Style.hs b/src/Text/Layout/Table/Style.hs new file mode 100644 --- /dev/null +++ b/src/Text/Layout/Table/Style.hs @@ -0,0 +1,145 @@ +-- | This module provides a primitive styling facility. To make your own style +-- have a look at . +module Text.Layout.Table.Style where + +-- | Specifies the different letters to construct the non-content structure of a +-- table. +data TableStyle = TableStyle + { headerSepH :: Char + , headerSepLC :: Char + , headerSepRC :: Char + , headerSepC :: Char + , headerTopL :: Char + , headerTopR :: Char + , headerTopC :: Char + , headerTopH :: Char + , headerV :: Char + , groupV :: Char + , groupSepH :: Char + , groupSepC :: Char + , groupSepLC :: Char + , groupSepRC :: Char + , groupTopC :: Char + , groupTopL :: Char + , groupTopR :: Char + , groupTopH :: Char + , groupBottomC :: Char + , groupBottomL :: Char + , groupBottomR :: Char + , groupBottomH :: Char + } + +-- | My usual ASCII table style. +asciiRoundS :: TableStyle +asciiRoundS = TableStyle + { headerSepH = '=' + , headerSepLC = ':' + , headerSepRC = ':' + , headerSepC = '|' + , headerTopL = '.' + , headerTopR = '.' + , headerTopC = '.' + , headerTopH = '-' + , headerV = '|' + , groupV = '|' + , groupSepH = '-' + , groupSepC = '+' + , groupSepLC = ':' + , groupSepRC = ':' + , groupTopC = '.' + , groupTopL = '.' + , groupTopR = '.' + , groupTopH = '-' + , groupBottomC = '\'' + , groupBottomL = '\'' + , groupBottomR = '\'' + , groupBottomH = '-' + } + +-- | Uses special unicode characters to draw clean thin boxes. +unicodeS :: TableStyle +unicodeS = TableStyle + { headerSepH = '═' + , headerSepLC = '╞' + , headerSepRC = '╡' + , headerSepC = '╪' + , headerTopL = '┌' + , headerTopR = '┐' + , headerTopC = '┬' + , headerTopH = '─' + , headerV = '│' + , groupV = '│' + , groupSepH = '─' + , groupSepC = '┼' + , groupSepLC = '├' + , groupSepRC = '┤' + , groupTopC = '┬' + , groupTopL = '┌' + , groupTopR = '┐' + , groupTopH = '─' + , groupBottomC = '┴' + , groupBottomL = '└' + , groupBottomR = '┘' + , groupBottomH = '─' + } + +-- | Same as 'unicodeS' but uses bold headers. +unicodeBoldHeaderS :: TableStyle +unicodeBoldHeaderS = unicodeS + { headerSepH = '━' + , headerSepLC = '┡' + , headerSepRC = '┩' + , headerSepC = '╇' + , headerTopL = '┏' + , headerTopR = '┓' + , headerTopC = '┳' + , headerTopH = '━' + , headerV = '┃' + } + +-- | Same as 'unicodeS' but uses round edges. +unicodeRoundS :: TableStyle +unicodeRoundS = unicodeS + { groupTopL = roundedTL + , groupTopR = roundedTR + , groupBottomL = roundedBL + , groupBottomR = roundedBR + , headerTopL = roundedTL + , headerTopR = roundedTR + } + where + roundedTL = '╭' + roundedTR = '╮' + roundedBL = '╰' + roundedBR = '╯' + +-- | Uses bold lines. +unicodeBoldS :: TableStyle +unicodeBoldS = TableStyle + { headerSepH = '━' + , headerSepLC = '┣' + , headerSepRC = '┫' + , headerSepC = '╋' + , headerTopL = '┏' + , headerTopR = '┓' + , headerTopC = '┳' + , headerTopH = '━' + , headerV = '┃' + , groupV = '┃' + , groupSepH = '━' + , groupSepC = '╋' + , groupSepLC = '┣' + , groupSepRC = '┫' + , groupTopC = '┳' + , groupTopL = '┏' + , groupTopR = '┓' + , groupTopH = '━' + , groupBottomC = '┻' + , groupBottomL = '┗' + , groupBottomR = '┛' + , groupBottomH = '━' + } + +-- | Uses bold lines with exception of group seperators, which are striped slim. +unicodeBoldStripedS :: TableStyle +unicodeBoldStripedS = unicodeBoldS { groupSepH = '-', groupSepC = '┃', groupSepLC = '┃', groupSepRC = '┃' } diff --git a/table-layout.cabal b/table-layout.cabal new file mode 100644 --- /dev/null +++ b/table-layout.cabal @@ -0,0 +1,74 @@ +name: table-layout + +-- The package version. See the Haskell package versioning policy (PVP) +-- for standards guiding when and how versions should be incremented. +-- http://www.haskell.org/haskellwiki/Package_versioning_policy +-- PVP summary: +-+------- breaking API changes +-- | | +----- non-breaking API additions +-- | | | +--- code changes with no API change +version: 0.1.0.0 + +synopsis: Layout text as grid or table. + +description: + `table-layout` is a library for text-based table layout, it provides several + functions which help in this task from the ground up, although using them is + not necessary. It provides the following layout features: + . + * Fixed-size and arbitrarily sized columns + . + * Positional alignment of content + . + * Alignment of text at a character occurence + . + * Cut marks show that text has been trimmed + . + * Building fancy tables with optional headers and user styles + . + * Layout text justified over multiple rows + +-- URL for the project homepage or repository. +homepage: https://github.com/muesli4/table-layout +license: BSD3 +license-file: LICENSE +author: Moritz Bruder +maintainer: muesli4@gmail.com +category: Text +build-type: Simple +-- Extra files to be distributed with the package, such as examples or a +-- README. +-- extra-source-files: + +-- Constraint on the version of Cabal needed to build this package. +cabal-version: >=1.10 + +source-repository head + type: git + location: git://github.com/muesli4/table-layout.git + + +library + -- Modules exported by the library. + exposed-modules: Text.Layout.Table, Text.Layout.Table.Justify, Text.Layout.Table.PrimMod, Text.Layout.Table.Style + + -- Modules included in this library but not exported. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + other-extensions: RecordWildCards, MultiWayIf + + -- Other library packages from which modules are imported. + build-depends: base >=4.8 && <4.9 + + -- Directories containing source files. + hs-source-dirs: src + + -- Base language which the package is written in. + default-language: Haskell2010 + +executable table-layout-test-styles + main-is: Test.hs + build-depends: base >=4.8 && <4.9 + hs-source-dirs: src + other-modules: Text.Layout.Table + default-language: Haskell2010