diff --git a/src/Test.hs b/src/Test.hs --- a/src/Test.hs +++ b/src/Test.hs @@ -6,35 +6,28 @@ main :: IO () main = putStrLn $ layoutTableToString rowGroups - (Just (["Layout", "Result"], repeat centerHL)) - [ LayoutSpec (ExpandUntil 30) LeftPos (charAlign ':') ellipsisCutMark - , LayoutSpec Expand CenterPos noAlign noCutMark + (Just (["Layout", "Result"], repeat def)) + [ column (expandUntil 30) left (charAlign ':') ellipsisCutMark + , column expand center noAlign noCutMark ] unicodeRoundS where rowGroups = flip concatMap styles $ \style -> - flip map layouts $ \layout -> - rowGroup $ columnsAsGrid CenterVPos [ explain layout - , genTable layout style - ] - genTable l s = layoutTableToLines [ rowGroup [ [longText, smallNum, "foo"] + flip map columTs $ \(cSpec, is) -> + rowGroup $ columnsAsGrid center [ is + , genTable cSpec style + ] + genTable c s = layoutTableToLines [ rowGroup [ [longText, smallNum, "foo"] , [shortText, bigNum, "bar"] ] ] - (Just (["Some text", "Some numbers", "X"], repeat centerHL)) - (repeat l) + (Just (["Some text", "Some numbers", "X"], repeat def)) + (repeat c) s longText = "This is long text" shortText = "Short" bigNum = "200300400500600.2" smallNum = "4.20000000" - explain l = case l of - LayoutSpec lenSpec posSpec alignSpec cutMarkSpec -> - [ "length: " ++ show lenSpec - , "position: " ++ show posSpec - , "alignment: " ++ if isAligned alignSpec then "at some point" else "not aligned" - , "cut mark: " ++ show cutMarkSpec - ] styles = [ asciiRoundS , unicodeS , unicodeRoundS @@ -42,8 +35,11 @@ , unicodeBoldStripedS , unicodeBoldHeaderS ] - layouts = [ LayoutSpec l p a ellipsisCutMark - | l <- [Expand, Fixed 10, ExpandUntil 10, FixedUntil 10] - , p <- [LeftPos, RightPos, CenterPos] - , a <- [noAlign, dotAlign] + columTs = [ ( column l p a ellipsisCutMark + , ["len spec: " ++ dL, "position: " ++ pL, "alignment: " ++ aL] + ) + | (l, dL) <- zip [expand, fixed 10, expandUntil 10, fixedUntil 10] + ["expand", "fixed 10", "expand until 10", "fixed until 10"] + , (p, pL) <- zip [left, right, center] ["left", "right", "center"] + , (a, aL) <- zip [noAlign, dotAlign] ["no align", "align at '.'"] ] diff --git a/src/Text/Layout/Table.hs b/src/Text/Layout/Table.hs --- a/src/Text/Layout/Table.hs +++ b/src/Text/Layout/Table.hs @@ -6,13 +6,13 @@ -- == Some examples -- Layouting text as a plain grid: -- --- >>> putStrLn $ layoutToString [["a", "b"], ["c", "d"]] (repeat defaultL) +-- >>> putStrLn $ layoutToString [["a", "b"], ["c", "d"]] (repeat def) -- a b -- c d -- -- Fancy table without header: -- --- >>> putStrLn $ layoutTableToString [rowGroup [["Jack", "184.74"]], rowGroup [["Jane", "162.2"]]] Nothing [defaultL, numL] unicodeRoundS +-- >>> putStrLn $ layoutTableToString [rowGroup [["Jack", "184.74"]], rowGroup [["Jane", "162.2"]]] Nothing [def , numL] unicodeRoundS -- ╭──────┬────────╮ -- │ Jack │ 184.74 │ -- ├──────┼────────┤ @@ -24,10 +24,10 @@ -- >>> putStrLn $ layoutTableToString [ rowGroup [["A very long text", "0.42000000"]] -- , rowGroup [["Short text", "100200.5"]] -- ] --- (Just (["Title", "Length"], repeat centerHL)) +-- (Just (["Title", "Length"], repeat def)) -- [ fixedLeftL 20 --- , LayoutSpec (Fixed 10) --- CenterPos +-- , ColSpec (fixed 10) +-- center -- dotAlign -- ellipsisCutMark -- ] @@ -45,13 +45,21 @@ module Text.Layout.Table ( -- * Layout types and combinators -- $layout - LayoutSpec(..) - , defaultL - , numL - , fixedL - , fixedLeftL - , LenSpec(..) - , PosSpec(..) + ColSpec + , column + , numCol + , fixedCol + , fixedLeftCol + , LenSpec + , expand + , fixed + , expandUntil + , fixedUntil + , Position + , H + , left + , right + , center , AlignSpec , noAlign , charAlign @@ -60,11 +68,11 @@ , isAligned , OccSpec , CutMarkSpec - , defaultCutMark , ellipsisCutMark , noCutMark , singleCutMark , cutMark + , module Data.Default.Class -- * Basic grid and table layout , layoutToCells @@ -78,9 +86,8 @@ -- * Advanced table layout , RowGroup , rowGroup - , HeaderLayoutSpec(..) - , centerHL - , leftHL + , HeaderColSpec + , headerColumn , layoutTableToLines , layoutTableToString @@ -88,8 +95,10 @@ -- $justify , justify , justifyText - , VertPosSpec(..) , columnsAsGrid + , top + , bottom + , V , justifyTextsAsGrid , justifyWordListsAsGrid @@ -103,13 +112,13 @@ , alignFixed -- * Column modifaction primitives - , ColModInfo(..) + , ColModInfo , widthCMI , unalignedCMI , ensureWidthCMI , ensureWidthOfCMI , columnModifier - , AlignInfo(..) + , AlignInfo , widthAI , deriveColModInfos , deriveAlignInfo @@ -119,44 +128,49 @@ -- 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 LayoutSpec: add some kind of combinator to construct LayoutSpec values (e.g. via Monoid, see optparse-applicative) +-- TODO ColSpec: add some kind of combinator to construct ColSpec values (e.g. via Monoid, see optparse-applicative) +-- TODO OccSpec: expose smart constructors -import Control.Arrow -import Data.List -import Data.Maybe +import qualified Control.Arrow as A +import Data.List +import Data.Maybe +import Data.Default.Class -import Text.Layout.Table.PrimMod -import Text.Layout.Table.Justify -import Text.Layout.Table.Style +import Text.Layout.Table.Justify +import Text.Layout.Table.Style +import Text.Layout.Table.Position +import Text.Layout.Table.Primitives.Basic +import Text.Layout.Table.Internal ------------------------------------------------------------------------------- -- Layout types and combinators ------------------------------------------------------------------------------- {- $layout - Specify the layout of columns. Layout combinators have a 'L' as postfix. + Specify the layout of columns. -} --- | Determines the layout of a column. -data LayoutSpec = LayoutSpec - { lenSpec :: LenSpec - , posSpec :: PosSpec - , alignSpec :: AlignSpec - , cutMarkSpec :: CutMarkSpec - } +column :: LenSpec -> Position H -> AlignSpec -> CutMarkSpec -> ColSpec +column = ColSpec --- | Determines how long a column will be. -data LenSpec = Expand | Fixed Int | ExpandUntil Int | FixedUntil Int deriving Show +instance Default ColSpec where + def = column def def def def --- | 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 +-- | Allows columns to use as much space as needed. +expand :: LenSpec +expand = Expand --- | Determines whether a column will align at a specific letter. -data AlignSpec = AlignPred OccSpec | NoAlign +-- | Fixes column length to a specific width. +fixed :: Int -> LenSpec +fixed = Fixed --- | Specifies an occurence of a letter. -data OccSpec = OccSpec (Char -> Bool) Int +-- | The column will expand as long as it is smaller as the given width. +expandUntil :: Int -> LenSpec +expandUntil = ExpandUntil +-- | The column will be at least as wide as the given width. +fixedUntil :: Int -> LenSpec +fixedUntil = FixedUntil + -- | Don't align text. noAlign :: AlignSpec noAlign = NoAlign @@ -167,7 +181,7 @@ charAlign :: Char -> AlignSpec charAlign = predAlign . (==) --- | Align all text at the dot. +-- | Align all text at the first dot from left. dotAlign :: AlignSpec dotAlign = charAlign '.' @@ -176,37 +190,25 @@ NoAlign -> False _ -> True --- | Use the same cut mark for left and right. -singleCutMark :: String -> CutMarkSpec -singleCutMark l = cutMark l (reverse l) +-- | No alignment is the default. +instance Default AlignSpec where + def = noAlign --- | Default cut mark used when cutting off text. -defaultCutMark :: CutMarkSpec -defaultCutMark = singleCutMark ".." +instance Default LenSpec where + def = Expand --- | 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 dotAlign defaultCutMark +numCol :: ColSpec +numCol = ColSpec def right dotAlign def --- | Fixes the column length and positions according to the given 'PosSpec'. -fixedL :: Int -> PosSpec -> LayoutSpec -fixedL l pS = LayoutSpec (Fixed l) pS NoAlign defaultCutMark +-- | Fixes the column length and positions according to the given 'Position'. +fixedCol :: Int -> Position H -> ColSpec +fixedCol l pS = ColSpec (Fixed l) pS def def -- | Fixes the column length and positions on the left. -fixedLeftL :: Int -> LayoutSpec -fixedLeftL i = fixedL i LeftPos +fixedLeftCol :: Int -> ColSpec +fixedLeftCol i = fixedCol i left ------------------------------------------------------------------------------- -- Single-cell layout functions. @@ -215,27 +217,27 @@ -- | 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" +-- >>> pad left 10 "foo" -- "foo " -- -pad :: PosSpec -> Int -> String -> String +pad :: Position o -> Int -> String -> String pad p = case p of - LeftPos -> fillRight - RightPos -> fillLeft - CenterPos -> fillCenter + Start -> fillRight + Center -> fillCenter + End -> fillLeft -- | 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." +-- >>> trimOrPad left (singleCutMark "..") 10 "A longer text." -- "A longer.." -- -trimOrPad :: PosSpec -> CutMarkSpec -> Int -> String -> String +trimOrPad :: Position o -> CutMarkSpec -> Int -> String -> String trimOrPad p = case p of - LeftPos -> fitRightWith - RightPos -> fitLeftWith - CenterPos -> fitCenterWith + Start -> fitRightWith + Center -> fitLeftWith + End -> 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 @@ -254,7 +256,7 @@ -- | 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 :: Position o -> 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 = @@ -263,17 +265,17 @@ then pad p i $ align oS ai s else case splitAtOcc oS s of (ls, rs) -> case p of - LeftPos -> + Start -> let remRight = r - n in if remRight < 0 then fitRight (l + remRight) $ fillLeft l ls else fillLeft l ls ++ fitRight remRight rs - RightPos -> + End -> let remLeft = l - n in if remLeft < 0 then fitLeft (r + remLeft) $ fillRight r rs else fitLeft remLeft ls ++ fillRight r rs - CenterPos -> + Center -> let (q, rem) = n `divMod` 2 remLeft = l - q remRight = r - q - rem @@ -288,7 +290,7 @@ applyMarkRight = applyMarkRightWith cms splitAtOcc :: OccSpec -> String -> (String, String) -splitAtOcc (OccSpec p occ) = first reverse . go 0 [] +splitAtOcc (OccSpec p occ) = A.first reverse . go 0 [] where go n ls xs = case xs of [] -> (ls, []) @@ -320,35 +322,36 @@ -- | 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 +ensureWidthCMI :: Int -> Position H -> ColModInfo -> ColModInfo +ensureWidthCMI w pos 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 + 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 -> PosSpec -> ColModInfo -> ColModInfo +ensureWidthOfCMI :: String -> Position H -> 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 +-- 'Position H', 'CutMarkSpec' and 'ColModInfo'. +columnModifier :: Position H -> CutMarkSpec -> ColModInfo -> (String -> String) +columnModifier pos cms lenInfo = case lenInfo of FillAligned oS ai -> align oS ai - FillTo maxLen -> pad posSpec maxLen + FillTo maxLen -> pad pos maxLen FitTo lim mT -> - maybe (trimOrPad posSpec cms lim) (uncurry $ alignFixed posSpec cms lim) mT + maybe (trimOrPad pos cms lim) (uncurry $ alignFixed pos cms lim) mT +-- TODO factor out -- | Specifies the length before and after a letter. -data AlignInfo = AlignInfo Int Int deriving Show +data AlignInfo = AlignInfo Int Int -- | The column width when using the 'AlignInfo'. widthAI :: AlignInfo -> Int @@ -397,22 +400,22 @@ -- Basic layout ------------------------------------------------------------------------------- --- | Modifies cells according to the given 'LayoutSpec'. -layoutToCells :: [[String]] -> [LayoutSpec] -> [[String]] +-- | Modifies cells according to the given 'ColSpec'. +layoutToCells :: [[String]] -> [ColSpec] -> [[String]] layoutToCells tab specs = zipWith apply tab . repeat - . zipWith (uncurry columnModifier) (map (posSpec &&& cutMarkSpec) specs) - $ deriveColModInfos (map (lenSpec &&& alignSpec) specs) tab + . zipWith (uncurry columnModifier) (map (position A.&&& cutMarkSpec) specs) + $ deriveColModInfos (map (lenSpec A.&&& alignSpec) specs) tab where apply = zipWith $ flip ($) -- | Behaves like 'layoutCells' but produces lines by joining with whitespace. -layoutToLines :: [[String]] -> [LayoutSpec] -> [String] +layoutToLines :: [[String]] -> [ColSpec] -> [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 :: [[String]] -> [ColSpec] -> String layoutToString tab specs = intercalate "\n" $ layoutToLines tab specs ------------------------------------------------------------------------------- @@ -434,34 +437,24 @@ -- 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 +-- | Header columns are usually centered. +instance Default HeaderColSpec where + def = headerColumn center Nothing --- | A left-positioned header layout. -leftHL :: HeaderLayoutSpec -leftHL = HeaderLayoutSpec LeftPos Nothing +headerColumn :: Position H -> Maybe CutMarkSpec -> HeaderColSpec +headerColumn = HeaderColSpec -- | 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 +layoutTableToLines :: [RowGroup] -- ^ Groups + -> Maybe ([String], [HeaderColSpec]) -- ^ Optional header details + -> [ColSpec] -- ^ Layout specification of columns + -> TableStyle -- ^ Visual table style -> [String] layoutTableToLines rGs optHeaderInfo specs (TableStyle { .. }) = topLine : addHeaderLines (rowGroupLines ++ [bottomLine]) @@ -484,12 +477,12 @@ -- Optional values for the header (addHeaderLines, fitHeaderIntoCMIs, realTopH, realTopL, realTopC, realTopR) = case optHeaderInfo of - Just (h, headerLayoutSpecs) -> + Just (h, headerColSpecs) -> let headerLine = vLine ' ' headerV (zipApply h headerRowMods) - headerRowMods = zipWith3 (\(HeaderLayoutSpec posSpec optCutMarkSpec) cutMarkSpec -> - columnModifier posSpec $ fromMaybe cutMarkSpec optCutMarkSpec + headerRowMods = zipWith3 (\(HeaderColSpec pos optCutMarkSpec) cutMarkSpec -> + columnModifier pos $ fromMaybe cutMarkSpec optCutMarkSpec ) - headerLayoutSpecs + headerColSpecs cMSs (map unalignedCMI cMIs) in @@ -510,17 +503,17 @@ ) cMSs = map cutMarkSpec specs - posSpecs = map posSpec specs + posSpecs = map position specs applyRowMods xss = zipWith zipApply xss $ repeat rowMods rowMods = zipWith3 columnModifier posSpecs cMSs cMIs - cMIs = fitHeaderIntoCMIs $ deriveColModInfos (map (lenSpec &&& alignSpec) specs) + cMIs = fitHeaderIntoCMIs $ deriveColModInfos (map (lenSpec A.&&& alignSpec) specs) $ concatMap rows rGs colWidths = map widthCMI cMIs zipApply = zipWith $ flip ($) layoutTableToString :: [RowGroup] - -> Maybe ([String], [HeaderLayoutSpec]) - -> [LayoutSpec] + -> Maybe ([String], [HeaderColSpec]) + -> [ColSpec] -> TableStyle -> String layoutTableToString rGs optHeaderInfo specs = intercalate "\n" . layoutTableToLines rGs optHeaderInfo specs diff --git a/src/Text/Layout/Table/Internal.hs b/src/Text/Layout/Table/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Text/Layout/Table/Internal.hs @@ -0,0 +1,30 @@ +module Text.Layout.Table.Internal where + +import Text.Layout.Table.Position +import Text.Layout.Table.Primitives.Basic + +-- | Specifies the layout of a column. +data ColSpec = ColSpec + { lenSpec :: LenSpec + , position :: Position H + , alignSpec :: AlignSpec + , cutMarkSpec :: CutMarkSpec + } + +-- | Determines how long a column will be. +data LenSpec = Expand | Fixed Int | ExpandUntil Int | FixedUntil Int + +-- | Determines whether a column will align at a specific letter. +data AlignSpec = AlignPred OccSpec | NoAlign + +-- | Specifies an occurence of a letter. +data OccSpec = OccSpec (Char -> Bool) Int + +-- | Groups rows together, which are not seperated from each other. +data RowGroup = RowGroup + { rows :: [[String]] + } + +-- | Specifies how a header is layout, by omitting the cut mark it will use the +-- one specified in the 'ColSpec' like the other cells in that column. +data HeaderColSpec = HeaderColSpec (Position H) (Maybe CutMarkSpec) diff --git a/src/Text/Layout/Table/Justify.hs b/src/Text/Layout/Table/Justify.hs --- a/src/Text/Layout/Table/Justify.hs +++ b/src/Text/Layout/Table/Justify.hs @@ -10,7 +10,6 @@ , dimorphicSummands , dimorphicSummandsBy -- * Vertical alignment of whole columns - , VertPosSpec(..) , columnsAsGrid , vpadCols ) where @@ -18,7 +17,8 @@ import Control.Arrow import Data.List -import Text.Layout.Table.PrimMod +import Text.Layout.Table.Primitives.Basic +import Text.Layout.Table.Position -- | Justifies texts and presents the resulting lines in a grid structure (each -- text in one column). @@ -29,31 +29,27 @@ -- 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 TopVPos . fmap (uncurry justify) - -data VertPosSpec = TopVPos - | CenterVPos - | BottomVPos +justifyWordListsAsGrid = columnsAsGrid top . fmap (uncurry justify) {- | Merges multiple columns together and merges them to a valid grid without holes. The following example clarifies this: ->>> columnsAsGrid TopVPos [justifyText 10 "This text will not fit on one line.", ["42", "23"]] +>>> columnsAsGrid top [justifyText 10 "This text will not fit on one line.", ["42", "23"]] [["This text","42"],["will not","23"],["fit on one",""],["line.",""]] -} -columnsAsGrid :: VertPosSpec -> [[[a]]] -> [[[a]]] -columnsAsGrid vPosSpec = transpose . vpadCols vPosSpec [] +columnsAsGrid :: Position V -> [[[a]]] -> [[[a]]] +columnsAsGrid vPos = transpose . vpadCols vPos [] -- | Fill all sublists to the same length. -vpadCols :: VertPosSpec -> a -> [[a]] -> [[a]] -vpadCols vPosSpec x l = fmap fillToMax l +vpadCols :: Position V -> a -> [[a]] -> [[a]] +vpadCols vPos x l = fmap fillToMax l where fillToMax = fillTo $ maximum $ 0 : fmap length l - fillTo = let f = case vPosSpec of - TopVPos -> fillEnd - CenterVPos -> fillBoth - BottomVPos -> fillStart + fillTo = let f = case vPos of + Start -> fillEnd + Center -> fillBoth + End -> fillStart in f x -- | Uses 'words' to split the text into words and justifies it with 'justify'. diff --git a/src/Text/Layout/Table/Position.hs b/src/Text/Layout/Table/Position.hs new file mode 100644 --- /dev/null +++ b/src/Text/Layout/Table/Position.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE PatternSynonyms #-} +module Text.Layout.Table.Position where + +import Data.Default.Class + +-- | Specifies a position relative from a beginning. +data Position orientation = Start | Center | End deriving Show + +instance Default (Position o) where + def = Start + +-- | Horizontal orientation. +data H + +-- | Vertical orientation +data V + +left :: Position H +left = Start + +right :: Position H +right = End + +center :: Position o +center = Center + +top :: Position V +top = Start + +bottom :: Position V +bottom = End diff --git a/src/Text/Layout/Table/PrimMod.hs b/src/Text/Layout/Table/PrimMod.hs deleted file mode 100644 --- a/src/Text/Layout/Table/PrimMod.hs +++ /dev/null @@ -1,125 +0,0 @@ --- | This module contains primitive modifiers for lists and 'String's to be --- filled or fitted to a specific length. -module Text.Layout.Table.PrimMod - ( -- * String-related tools - CutMarkSpec - , cutMark - , spaces - , fillLeft' - , fillLeft - , fillRight - , fillCenter' - , fillCenter - , fitRightWith - , fitLeftWith - , fitCenterWith - , applyMarkLeftWith - , applyMarkRightWith - - -- * List-related tools - , fillStart' - , fillStart - , fillEnd - , fillBoth' - , fillBoth - ) - 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 ' ' - -fillStart' :: a -> Int -> Int -> [a] -> [a] -fillStart' x i lenL l = replicate (i - lenL) x ++ l - -fillStart :: a -> Int -> [a] -> [a] -fillStart x i l = fillStart' x i (length l) l - -fillEnd :: a -> Int -> [a] -> [a] -fillEnd x i l = take i $ l ++ repeat x - -fillBoth' :: a -> Int -> Int -> [a] -> [a] -fillBoth' x i lenL l = - -- Puts more on the beginning if odd. - filler q ++ l ++ filler (q + r) - where - filler = flip replicate x - missing = i - lenL - (q, r) = missing `divMod` 2 - -fillBoth :: a -> Int -> [a] -> [a] -fillBoth x i l = fillBoth' x i (length l) l - -fillLeft' :: Int -> Int -> String -> String -fillLeft' = fillStart' ' ' - --- | Fill on the left until the 'String' has the desired length. -fillLeft :: Int -> String -> String -fillLeft = fillStart ' ' - --- | Fill on the right until the 'String' has the desired length. -fillRight :: Int -> String -> String -fillRight = fillEnd ' ' - -fillCenter' :: Int -> Int -> String -> String -fillCenter' = fillBoth' ' ' - --- | Fill on both sides equally until the 'String' has the desired length. -fillCenter :: Int -> String -> String -fillCenter = fillBoth ' ' - --- | 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/Primitives/Basic.hs b/src/Text/Layout/Table/Primitives/Basic.hs new file mode 100644 --- /dev/null +++ b/src/Text/Layout/Table/Primitives/Basic.hs @@ -0,0 +1,147 @@ +-- | This module contains primitive modifiers for lists and 'String's to be +-- filled or fitted to a specific length. +module Text.Layout.Table.Primitives.Basic + ( -- * Cut marks + CutMarkSpec + , cutMark + , singleCutMark + , noCutMark + , ellipsisCutMark + + -- * String-related tools + , spaces + , fillLeft' + , fillLeft + , fillRight + , fillCenter' + , fillCenter + , fitRightWith + , fitLeftWith + , fitCenterWith + , applyMarkLeftWith + , applyMarkRightWith + + -- * List-related tools + , fillStart' + , fillStart + , fillEnd + , fillBoth' + , fillBoth + ) + where + +import Data.Default.Class + +-- | 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 Default CutMarkSpec where + def = ellipsisCutMark + +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) + +-- | Use the same cut mark for left and right. +singleCutMark :: String -> CutMarkSpec +singleCutMark l = cutMark l (reverse l) + +-- | 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 "…" + +spaces :: Int -> String +spaces = flip replicate ' ' + +fillStart' :: a -> Int -> Int -> [a] -> [a] +fillStart' x i lenL l = replicate (i - lenL) x ++ l + +fillStart :: a -> Int -> [a] -> [a] +fillStart x i l = fillStart' x i (length l) l + +fillEnd :: a -> Int -> [a] -> [a] +fillEnd x i l = take i $ l ++ repeat x + +fillBoth' :: a -> Int -> Int -> [a] -> [a] +fillBoth' x i lenL l = + -- Puts more on the beginning if odd. + filler q ++ l ++ filler (q + r) + where + filler = flip replicate x + missing = i - lenL + (q, r) = missing `divMod` 2 + +fillBoth :: a -> Int -> [a] -> [a] +fillBoth x i l = fillBoth' x i (length l) l + +fillLeft' :: Int -> Int -> String -> String +fillLeft' = fillStart' ' ' + +-- | Fill on the left until the 'String' has the desired length. +fillLeft :: Int -> String -> String +fillLeft = fillStart ' ' + +-- | Fill on the right until the 'String' has the desired length. +fillRight :: Int -> String -> String +fillRight = fillEnd ' ' + +fillCenter' :: Int -> Int -> String -> String +fillCenter' = fillBoth' ' ' + +-- | Fill on both sides equally until the 'String' has the desired length. +fillCenter :: Int -> String -> String +fillCenter = fillBoth ' ' + +-- | 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/table-layout.cabal b/table-layout.cabal --- a/table-layout.cabal +++ b/table-layout.cabal @@ -6,7 +6,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.3.0.0 +version: 0.4.0.0 synopsis: Layout text as grid or table. @@ -52,7 +52,7 @@ library -- Modules exported by the library. - exposed-modules: Text.Layout.Table, Text.Layout.Table.Justify, Text.Layout.Table.PrimMod, Text.Layout.Table.Style + exposed-modules: Text.Layout.Table, Text.Layout.Table.Justify, Text.Layout.Table.Style, Text.Layout.Table.Position, Text.Layout.Table.Primitives.Basic, Text.Layout.Table.Internal -- Modules included in this library but not exported. -- other-modules: @@ -61,7 +61,7 @@ other-extensions: RecordWildCards, MultiWayIf -- Other library packages from which modules are imported. - build-depends: base >=4.8 && <4.9 + build-depends: base >=4.8 && <4.9, data-default-class ==0.0.1 -- Directories containing source files. hs-source-dirs: src @@ -71,7 +71,7 @@ executable table-layout-test-styles main-is: Test.hs - build-depends: base >=4.8 && <4.9 + build-depends: base >=4.8 && <4.9, data-default-class ==0.0.1 hs-source-dirs: src other-modules: Text.Layout.Table default-language: Haskell2010