{-# LANGUAGE FlexibleInstances #-}
module Text.Layout.Table.Cell where
import Text.Layout.Table.Primitives.AlignInfo
import Text.Layout.Table.Spec.CutMark
import Text.Layout.Table.Spec.OccSpec
import Text.Layout.Table.Spec.Position
import Text.Layout.Table.StringBuilder
class Cell a where
dropLeft :: Int -> a -> a
dropLeft n = dropBoth n 0
dropRight :: Int -> a -> a
dropRight = dropBoth 0
dropBoth :: Int -> Int -> a -> a
dropBoth l r = dropRight r . dropLeft l
visibleLength :: a -> Int
measureAlignment :: (Char -> Bool) -> a -> AlignInfo
buildCell :: StringBuilder b => a -> b
{-# MINIMAL visibleLength, measureAlignment, buildCell, (dropBoth | (dropLeft, dropRight)) #-}
instance Cell String where
dropLeft = drop
dropRight n = reverse . drop n . reverse
visibleLength = length
measureAlignment p xs = case break p xs of
(ls, rs) -> AlignInfo (length ls) $ case rs of
[] -> Nothing
_ : rs' -> Just $ length rs'
buildCell = stringB
remSpacesB :: (Cell a, StringBuilder b) => Int -> a -> b
remSpacesB n c = remSpacesB' n $ visibleLength c
remSpacesB' :: StringBuilder b => Int -> Int -> b
remSpacesB' n k = spacesB $ n - k
fillRight :: (Cell a, StringBuilder b) => Int -> a -> b
fillRight n c = buildCell c <> remSpacesB n c
fillCenter :: (Cell a, StringBuilder b) => Int -> a -> b
fillCenter n c = spacesB q <> buildCell c <> spacesB (q + r)
where
missing = n - visibleLength c
(q, r) = missing `divMod` 2
fillLeft :: (Cell a, StringBuilder b) => Int -> a -> b
fillLeft n c = remSpacesB n c <> buildCell c
pad :: (Cell a, StringBuilder b) => Position o -> Int -> a -> b
pad p = case p of
Start -> fillRight
Center -> fillCenter
End -> fillLeft
trimOrPad :: (Cell a, StringBuilder b) => Position o -> CutMark -> Int -> a -> b
trimOrPad p cm n c = case compare (visibleLength c) n of
LT -> pad p n c
EQ -> buildCell c
GT -> trim p cm n c
trim :: (Cell a, StringBuilder b) => Position o -> CutMark -> Int -> a -> b
trim p cm n c = case p of
Start -> buildCell (dropRight (cutLen + rightLen) c) <> buildCell (rightMark cm)
Center -> case cutLen `divMod` 2 of
(0, 1) -> buildCell (leftMark cm) <> buildCell (dropLeft (1 + leftLen) c)
(q, r) -> if n > leftLen + rightLen
then buildCell (leftMark cm) <> buildCell (dropBoth (leftLen + q + r) (rightLen + q) c)
<> buildCell (rightMark cm)
else case n `divMod` 2 of
(qn, rn) -> buildCell (take qn $ leftMark cm)
<> buildCell (drop (rightLen - qn - rn) $ rightMark cm)
End -> buildCell (leftMark cm) <> buildCell (dropLeft (leftLen + cutLen) c)
where
leftLen = length $ leftMark cm
rightLen = length $ rightMark cm
cutLen = visibleLength c - n
align :: (Cell a, StringBuilder b) => OccSpec -> AlignInfo -> a -> b
align oS (AlignInfo ln optRN) c = case measureAlignment (predicate oS) c of
AlignInfo lk optRK -> remSpacesB' ln lk <> buildCell c <> remSpacesB' (maybe 0 succ optRN) (maybe 0 succ optRK)
data CutAction
= FillCA Int
| CutCA Int
| NoneCA
deriving (Eq, Show)
surplusSpace :: CutAction -> Int
surplusSpace ca = case ca of
CutCA n -> negate n
FillCA n -> n
_ -> 0
determineCutAction :: Int -> Int -> CutAction
determineCutAction requiredW actualW = case compare requiredW actualW of
LT -> CutCA $ actualW - requiredW
EQ -> NoneCA
GT -> FillCA $ requiredW - actualW
data CutInfo
= SidesCI CutAction CutAction
| MarkLeftCI
| MarkRightCI
deriving (Eq, Show)
determineCuts :: Int -> Int -> Int -> Int -> CutInfo
determineCuts vl vr cl cr
| vr <= cl = MarkRightCI
| cr <= vl = MarkLeftCI
| otherwise = SidesCI (determineCutAction cl vl) (determineCutAction vr cr)
spacesAfterCut :: StringBuilder b => CutAction -> Int -> Int -> b
spacesAfterCut ca cellLen cutAmount = spacesB $ s + min r 0
where
s = surplusSpace ca
r = cellLen - cutAmount
applyCutInfo
:: (Cell a, StringBuilder b)
=> CutInfo
-> CutMark
-> Int
-> Int
-> a
-> b
applyCutInfo ci cm availSpace cellLen c = case ci of
SidesCI (CutCA lCut) (CutCA rCut) ->
let (q, r) = availSpace `divMod` 2
in applyLeftMark q
<> buildCell (dropBoth (lCut + leftLen) (rCut + rightLen) c)
<> applyRightMark (q + r)
SidesCI (CutCA lCut) rCA ->
applyLeftMark availSpace
<> buildCell (dropLeft (lCut + leftLen) c)
<> spacesAfterCut rCA cellLen (lCut + leftLen)
SidesCI lCA (CutCA rCut) ->
spacesAfterCut lCA cellLen (rCut + rightLen)
<> buildCell (dropRight (rCut + rightLen) c)
<> applyRightMark availSpace
SidesCI lCA rCA ->
let spacesB' = spacesB . surplusSpace
in spacesB' lCA <> buildCell c <> spacesB' rCA
MarkRightCI ->
spacesB (max 0 $ availSpace - rightLen) <> applyRightMark availSpace
MarkLeftCI ->
applyLeftMark availSpace <> spacesB (max 0 $ availSpace - leftLen)
where
leftLen = length $ leftMark cm
rightLen = length $ rightMark cm
applyLeftMark k = buildCell $ take k $ leftMark cm
applyRightMark k = buildCell $ drop (rightLen - k) $ rightMark cm
viewRange :: Position o -> Int -> Int -> Int -> (Int, Int)
viewRange p availSpace l r = case p of
Start -> (0, availSpace)
Center -> let (cq, cr) = (l + r + 1 - availSpace) `divMod` 2
start = cq + cr
in (start, start + availSpace)
End -> let end = l + r + 1
in (end - availSpace, end)
cellRange :: Int -> AlignInfo -> (Int, Int)
cellRange lMax cellAlignInfo@(AlignInfo l _) = (cl, cl + widthAI cellAlignInfo)
where
cl = lMax - l
alignFixed
:: (Cell a, StringBuilder b)
=> Position o
-> CutMark
-> Int
-> OccSpec
-> AlignInfo
-> a
-> b
alignFixed p cm n oS (AlignInfo lMax optRMax) c = case optRMax of
Nothing -> trimOrPad p cm n c
Just rMax -> let (vl, vr) = viewRange p n lMax rMax
(cl, cr) = cellRange lMax $ measureAlignment (predicate oS) c
cutInfo = determineCuts vl vr cl cr
cellLen = cr - cl
in applyCutInfo cutInfo cm n cellLen c