table-layout (empty) → 0.1.0.0
raw patch · 8 files changed
+987/−0 lines, 8 filesdep +basesetup-changed
Dependencies added: base
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- src/Test.hs +34/−0
- src/Text/Layout/Table.hs +502/−0
- src/Text/Layout/Table/Justify.hs +102/−0
- src/Text/Layout/Table/PrimMod.hs +98/−0
- src/Text/Layout/Table/Style.hs +145/−0
- table-layout.cabal +74/−0
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Test.hs view
@@ -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]+ ]
+ src/Text/Layout/Table.hs view
@@ -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.+--
+ src/Text/Layout/Table/Justify.hs view
@@ -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
+ src/Text/Layout/Table/PrimMod.hs view
@@ -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
+ src/Text/Layout/Table/Style.hs view
@@ -0,0 +1,145 @@+-- | This module provides a primitive styling facility. To make your own style+-- have a look at <https://en.wikipedia.org/wiki/Box-drawing_character>.+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 = '┃' }
+ table-layout.cabal view
@@ -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