module Text.Layout.Table
(
ColSpec
, column
, numCol
, fixedCol
, fixedLeftCol
, LenSpec
, expand
, fixed
, expandUntil
, fixedUntil
, Position
, H
, left
, right
, center
, AlignSpec
, noAlign
, charAlign
, predAlign
, dotAlign
, isAligned
, OccSpec
, CutMarkSpec
, ellipsisCutMark
, noCutMark
, singleCutMark
, cutMark
, module Data.Default.Class
, layoutToCells
, layoutToLines
, layoutToString
, altLines
, checkeredCells
, RowGroup
, rowGroup
, HeaderColSpec
, headerColumn
, layoutTableToLines
, layoutTableToString
, justify
, justifyText
, columnsAsGrid
, top
, bottom
, V
, justifyTextsAsGrid
, justifyWordListsAsGrid
, module Text.Layout.Table.Style
, pad
, trimOrPad
, align
, alignFixed
, ColModInfo
, widthCMI
, unalignedCMI
, ensureWidthCMI
, ensureWidthOfCMI
, columnModifier
, AlignInfo
, widthAI
, deriveColModInfos
, deriveAlignInfo
) where
import qualified Control.Arrow as A
import Data.List
import Data.Maybe
import Data.Default.Class
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
column :: LenSpec -> Position H -> AlignSpec -> CutMarkSpec -> ColSpec
column = ColSpec
instance Default ColSpec where
def = column def def def def
expand :: LenSpec
expand = Expand
fixed :: Int -> LenSpec
fixed = Fixed
expandUntil :: Int -> LenSpec
expandUntil = ExpandUntil
fixedUntil :: Int -> LenSpec
fixedUntil = FixedUntil
noAlign :: AlignSpec
noAlign = NoAlign
predAlign :: (Char -> Bool) -> AlignSpec
predAlign p = AlignPred $ OccSpec p 0
charAlign :: Char -> AlignSpec
charAlign = predAlign . (==)
dotAlign :: AlignSpec
dotAlign = charAlign '.'
isAligned :: AlignSpec -> Bool
isAligned as = case as of
NoAlign -> False
_ -> True
instance Default AlignSpec where
def = noAlign
instance Default LenSpec where
def = Expand
numCol :: ColSpec
numCol = ColSpec def right dotAlign def
fixedCol :: Int -> Position H -> ColSpec
fixedCol l pS = ColSpec (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 -> CutMarkSpec -> 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
[] -> (if r == 0 then "" else spaces r)
_ -> fillRight r rs
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 =
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
Start ->
let remRight = r n
in if remRight < 0
then fitRight (l + remRight) $ fillLeft l ls
else fillLeft l ls ++ fitRight remRight rs
End ->
let remLeft = l n
in if remLeft < 0
then fitLeft (r + remLeft) $ fillRight r rs
else fitLeft remLeft ls ++ fillRight r rs
Center ->
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 p occ) = A.first reverse . go 0 []
where
go n ls xs = case xs of
[] -> (ls, [])
x : xs' -> if p x
then if n == occ
then (ls, xs)
else go (succ n) (x : ls) xs'
else go n (x : ls) xs'
data ColModInfo = FillAligned OccSpec AlignInfo
| FillTo Int
| FitTo Int (Maybe (OccSpec, AlignInfo))
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 = widthAI ai w
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 -> CutMarkSpec -> 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
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)] -> [[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
AlignPred 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 :: [[String]] -> [ColSpec] -> [[String]]
layoutToCells tab specs = zipWith apply tab
. repeat
. zipWith (uncurry columnModifier) (map (position A.&&& cutMarkSpec) specs)
$ deriveColModInfos (map (lenSpec A.&&& alignSpec) specs) tab
where
apply = zipWith $ flip ($)
layoutToLines :: [[String]] -> [ColSpec] -> [String]
layoutToLines tab specs = map unwords $ layoutToCells tab specs
layoutToString :: [[String]] -> [ColSpec] -> String
layoutToString tab specs = intercalate "\n" $ 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]]
rowGroup :: [[String]] -> RowGroup
rowGroup = RowGroup
instance Default HeaderColSpec where
def = headerColumn center Nothing
headerColumn :: Position H -> Maybe CutMarkSpec -> HeaderColSpec
headerColumn = HeaderColSpec
layoutTableToLines :: [RowGroup]
-> Maybe ([String], [HeaderColSpec])
-> [ColSpec]
-> TableStyle
-> [String]
layoutTableToLines rGs optHeaderInfo specs (TableStyle { .. }) =
topLine : addHeaderLines (rowGroupLines ++ [bottomLine])
where
vLine hs d = vLineDetail hs d d d
vLineDetail hS dL d dR cols = intercalate [hS] $ [dL] : intersperse [d] cols ++ [[dR]]
genHSpacers c = map (flip replicate c) colWidths
topLine = vLineDetail realTopH realTopL realTopC realTopR $ genHSpacers realTopH
bottomLine = vLineDetail groupBottomH groupBottomL groupBottomC groupBottomR $ genHSpacers groupBottomH
groupSepLine = vLineDetail groupSepH groupSepLC groupSepC groupSepRC $ genHSpacers groupSepH
headerSepLine = vLineDetail headerSepH headerSepLC headerSepC headerSepRC $ genHSpacers headerSepH
rowGroupLines = intercalate [groupSepLine] $ map (map (vLine ' ' groupV) . applyRowMods . rows) rGs
(addHeaderLines, fitHeaderIntoCMIs, realTopH, realTopL, realTopC, realTopR) = case optHeaderInfo of
Just (h, headerColSpecs) ->
let headerLine = vLine ' ' headerV (zipApply h headerRowMods)
headerRowMods = zipWith3 (\(HeaderColSpec pos optCutMarkSpec) cutMarkSpec ->
columnModifier pos $ fromMaybe cutMarkSpec optCutMarkSpec
)
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 cutMarkSpec 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 = intercalate "\n" . layoutTableToLines rGs optHeaderInfo specs