module Text.Layout.Table
(
module Data.Default.Class
, ColSpec
, column
, numCol
, fixedCol
, fixedLeftCol
, LenSpec
, expand
, fixed
, expandUntil
, fixedUntil
, Position
, H
, left
, right
, center
, AlignSpec
, noAlign
, charAlign
, predAlign
, dotAlign
, CutMark
, noCutMark
, singleCutMark
, doubleCutMark
, ellipsisCutMark
, Row
, layoutToCells
, layoutToLines
, layoutToString
, altLines
, checkeredCells
, RowGroup
, rowsG
, rowG
, colsG
, colsAllG
, HeaderColSpec
, headerColumn
, layoutTableToLines
, layoutTableToString
, justify
, justifyText
, Col
, colsAsRowsAll
, colsAsRows
, top
, bottom
, V
, module Text.Layout.Table.Style
, pad
, trimOrPad
, align
, alignFixed
, ColModInfo
, widthCMI
, unalignedCMI
, ensureWidthCMI
, ensureWidthOfCMI
, columnModifier
, AlignInfo
, widthAI
, deriveColModInfos
, deriveAlignInfo
, OccSpec
) where
import qualified Control.Arrow as A
import Data.List
import Data.Maybe
import Data.Default.Class
import Data.Default.Instances.Base ()
import Text.Layout.Table.Justify
import Text.Layout.Table.Style
import Text.Layout.Table.Position.Internal
import Text.Layout.Table.Primitives.AlignSpec.Internal
import Text.Layout.Table.Primitives.Basic
import Text.Layout.Table.Primitives.Column
import Text.Layout.Table.Primitives.LenSpec.Internal
import Text.Layout.Table.Primitives.Occurence
import Text.Layout.Table.Internal
import Text.Layout.Table.Vertical
dotAlign :: AlignSpec
dotAlign = charAlign '.'
numCol :: ColSpec
numCol = column def right dotAlign def
fixedCol :: Int -> Position H -> ColSpec
fixedCol l pS = column (fixed l) pS def def
fixedLeftCol :: Int -> ColSpec
fixedLeftCol i = fixedCol i left
pad :: Position o -> Int -> String -> String
pad p = case p of
Start -> fillRight
Center -> fillCenter
End -> fillLeft
trimOrPad :: Position o -> CutMark -> Int -> String -> String
trimOrPad p = case p of
Start -> fitRightWith
Center -> fitCenterWith
End -> fitLeftWith
align :: OccSpec -> AlignInfo -> String -> String
align oS (AlignInfo l r) s = case splitAtOcc oS s of
(ls, rs) -> fillLeft l ls ++ case rs of
[] -> spaces r
_ -> fillRight r rs
alignFixed :: Position o -> CutMark -> Int -> OccSpec -> AlignInfo -> String -> String
alignFixed _ cms 0 _ _ _ = ""
alignFixed _ cms 1 _ _ s@(_ : (_ : _)) = applyMarkLeftWith cms " "
alignFixed p cms i oS ai@(AlignInfo l r) s =
let n = l + r i
in case splitAtOcc oS s of
(ls, rs) -> case p of
Start ->
let remRight = r n
in if remRight < 0
then fitRight (l + remRight) $ fillLeft l ls
else fitRight (l + remRight) $ fillLeft l ls ++ rs
End ->
let remLeft = l n
in if remLeft < 0
then fitLeft (r + remLeft) $ fillRight r rs
else fitLeft (r + remLeft) $ ls ++ fillRight r rs
Center ->
let (c, remC) = (l + r) `divMod` 2
(d, remD) = i `divMod` 2
d2 = d + remD
c2 = c + remC
(widthL, widthR) = if l > c
then (l c2 + d, d2 (l c2))
else (d (r c), (c2 l) + d2)
lenL = length ls
lenR = length rs
toCutLfromR = negate $ min 0 widthL
toCutRfromL = max 0 $ negate widthR
(markL, funL) = if lenL > widthL
then ( applyMarkLeft
, take (widthL toCutRfromL) . drop (lenL widthL)
)
else ( id
, fillLeft (widthL toCutRfromL) . take (lenL toCutRfromL)
)
(markR, funR) = if lenR > widthR
then (applyMarkRight, take widthR)
else (id , fillRight widthR)
in markL $ markR $ funL ls ++ drop toCutLfromR (funR rs)
where
fitRight = fitRightWith cms
fitLeft = fitLeftWith cms
applyMarkRight = applyMarkRightWith cms
applyMarkLeft = applyMarkLeftWith cms
data ColModInfo = FillAligned OccSpec AlignInfo
| FillTo Int
| FitTo Int (Maybe (OccSpec, AlignInfo))
showCMI :: ColModInfo -> String
showCMI cmi = case cmi of
FillAligned oS ai -> "FillAligned .. " ++ showAI ai
FillTo i -> "FillTo " ++ show i
FitTo i _ -> "FitTo " ++ show i ++ ".."
widthCMI :: ColModInfo -> Int
widthCMI cmi = case cmi of
FillAligned _ ai -> widthAI ai
FillTo maxLen -> maxLen
FitTo lim _ -> lim
unalignedCMI :: ColModInfo -> ColModInfo
unalignedCMI cmi = case cmi of
FillAligned _ ai -> FillTo $ widthAI ai
FitTo i _ -> FitTo i Nothing
_ -> cmi
ensureWidthCMI :: Int -> Position H -> ColModInfo -> ColModInfo
ensureWidthCMI w pos cmi = case cmi of
FillAligned oS ai@(AlignInfo lw rw) ->
let neededW = w widthAI ai
in if neededW <= 0
then cmi
else FillAligned oS $ case pos of
Start -> AlignInfo lw (rw + neededW)
End -> AlignInfo (lw + neededW) rw
Center -> let (q, r) = neededW `divMod` 2
in AlignInfo (q + lw) (q + rw + r)
FillTo maxLen -> FillTo (max maxLen w)
_ -> cmi
ensureWidthOfCMI :: String -> Position H -> ColModInfo -> ColModInfo
ensureWidthOfCMI = ensureWidthCMI . length
columnModifier :: Position H -> CutMark -> ColModInfo -> (String -> String)
columnModifier pos cms lenInfo = case lenInfo of
FillAligned oS ai -> align oS ai
FillTo maxLen -> pad pos maxLen
FitTo lim mT ->
maybe (trimOrPad pos cms lim) (uncurry $ alignFixed pos cms lim) mT
data AlignInfo = AlignInfo Int Int
showAI :: AlignInfo -> String
showAI (AlignInfo l r) = "AlignInfo " ++ show l ++ " " ++ show r
widthAI :: AlignInfo -> Int
widthAI (AlignInfo l r) = l + r
instance Monoid AlignInfo where
mempty = AlignInfo 0 0
mappend (AlignInfo ll lr) (AlignInfo rl rr) = AlignInfo (max ll rl) (max lr rr)
deriveColModInfos :: [(LenSpec, AlignSpec)] -> [Row String] -> [ColModInfo]
deriveColModInfos specs = zipWith ($) (fmap fSel specs) . transpose
where
fSel (lenSpec, alignSpec) = case alignSpec of
NoAlign -> let fitTo i = const $ FitTo i Nothing
expandUntil f i max = if f (max <= i)
then FillTo max
else fitTo i max
fun = case lenSpec of
Expand -> FillTo
Fixed i -> fitTo i
ExpandUntil i -> expandUntil id i
FixedUntil i -> expandUntil not i
in fun . maximum . map length
AlignOcc oS -> let fitToAligned i = FitTo i . Just . (,) oS
fillAligned = FillAligned oS
expandUntil f i ai = if f (widthAI ai <= i)
then fillAligned ai
else fitToAligned i ai
fun = case lenSpec of
Expand -> fillAligned
Fixed i -> fitToAligned i
ExpandUntil i -> expandUntil id i
FixedUntil i -> expandUntil not i
in fun . foldMap (deriveAlignInfo oS)
deriveAlignInfo :: OccSpec -> String -> AlignInfo
deriveAlignInfo occSpec s = AlignInfo <$> length . fst <*> length . snd $ splitAtOcc occSpec s
layoutToCells :: [Row String] -> [ColSpec] -> [Row String]
layoutToCells tab specs = zipWith apply tab
. repeat
. zipWith (uncurry columnModifier) (map (position A.&&& cutMark) specs)
$ deriveColModInfos (map (lenSpec A.&&& alignSpec) specs) tab
where
apply = zipWith $ flip ($)
layoutToLines :: [Row String] -> [ColSpec] -> [String]
layoutToLines tab specs = map unwords $ layoutToCells tab specs
layoutToString :: [Row String] -> [ColSpec] -> String
layoutToString tab specs = concatLines $ layoutToLines tab specs
altLines :: [a -> b] -> [a] -> [b]
altLines = zipWith ($) . cycle
checkeredCells :: (a -> b) -> (a -> b) -> [[a]] -> [[b]]
checkeredCells f g = zipWith altLines $ cycle [[f, g], [g, f]]
colsG :: [Position V] -> [Col String] -> RowGroup
colsG ps = rowsG . colsAsRows ps
colsAllG :: Position V -> [Col String] -> RowGroup
colsAllG p = rowsG . colsAsRowsAll p
layoutTableToLines :: [RowGroup]
-> Maybe ([String], [HeaderColSpec])
-> [ColSpec]
-> TableStyle
-> [String]
layoutTableToLines rGs optHeaderInfo specs (TableStyle { .. }) =
topLine : addHeaderLines (rowGroupLines ++ [bottomLine])
where
hLine hS d = hLineDetail hS d d d
hLineDetail hS dL d dR cols = intercalate [hS] $ [dL] : intersperse [d] cols ++ [[dR]]
genHSpacers c = map (flip replicate c) colWidths
topLine = hLineDetail realTopH realTopL realTopC realTopR $ genHSpacers realTopH
bottomLine = hLineDetail groupBottomH groupBottomL groupBottomC groupBottomR $ genHSpacers groupBottomH
groupSepLine = hLineDetail groupSepH groupSepLC groupSepC groupSepRC $ genHSpacers groupSepH
headerSepLine = hLineDetail headerSepH headerSepLC headerSepC headerSepRC $ genHSpacers headerSepH
rowGroupLines = intercalate [groupSepLine] $ map (map (hLine ' ' groupV) . applyRowMods . rows) rGs
(addHeaderLines, fitHeaderIntoCMIs, realTopH, realTopL, realTopC, realTopR) = case optHeaderInfo of
Just (h, headerColSpecs) ->
let headerLine = hLine ' ' headerV (zipApply h headerRowMods)
headerRowMods = zipWith3 (\(HeaderColSpec pos optCutMark) cutMark ->
columnModifier pos $ fromMaybe cutMark optCutMark
)
headerColSpecs
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 cutMark specs
posSpecs = map position specs
applyRowMods xss = zipWith zipApply xss $ repeat rowMods
rowMods = zipWith3 columnModifier posSpecs cMSs cMIs
cMIs = fitHeaderIntoCMIs $ deriveColModInfos (map (lenSpec A.&&& alignSpec) specs)
$ concatMap rows rGs
colWidths = map widthCMI cMIs
zipApply = zipWith $ flip ($)
layoutTableToString :: [RowGroup]
-> Maybe ([String], [HeaderColSpec])
-> [ColSpec]
-> TableStyle
-> String
layoutTableToString rGs optHeaderInfo specs = concatLines . layoutTableToLines rGs optHeaderInfo specs