module Rainbox.Core where
import Control.Monad (join)
import qualified Data.Foldable as F
import Data.Function ((&))
import qualified Data.Map as M
import Data.Monoid ((<>))
import Data.Sequence (Seq, ViewL (EmptyL, (:<)), viewl,
(|>), (<|))
import qualified Data.Sequence as Seq
import Data.Text (Text)
import qualified Data.Text as X
import qualified Data.Traversable as T
import Lens.Micro.TH (makeLenses)
import Rainbow ( Chunk , Radiant , chunk , back)
import Rainbow.Types (Chunk (_yarn))
data Alignment a = Center | NonCenter a
deriving (Eq, Ord, Show, Functor, F.Foldable, T.Traversable)
instance Monoid (Alignment a) where
mempty = Center
mappend x y = case x of
Center -> y
NonCenter a -> case y of
Center -> NonCenter a
NonCenter b -> NonCenter b
data Horizontal = Top | Bottom
deriving (Eq, Ord, Show)
data Vertical = Port | Starboard
deriving (Eq, Ord, Show)
center :: Alignment a
center = Center
centerH :: Alignment Horizontal
centerH = center
centerV :: Alignment Vertical
centerV = center
left :: Alignment Vertical
left = NonCenter Port
right :: Alignment Vertical
right = NonCenter Starboard
top :: Alignment Horizontal
top = NonCenter Top
bottom :: Alignment Horizontal
bottom = NonCenter Bottom
newtype Height = Height Int
deriving (Eq, Ord, Show)
newtype Width = Width Int
deriving (Eq, Ord, Show)
class HasHeight a where
height :: a -> Int
instance HasHeight Height where
height (Height a) = max 0 a
instance HasHeight (Chunk a) where
height _ = 1
instance (HasHeight a, HasHeight b) => HasHeight (Either a b) where
height = either height height
class HasWidth a where
width :: a -> Int
instance HasWidth Width where
width (Width a) = max 0 a
instance HasWidth (Chunk Text) where
width ck = X.length . _yarn $ ck
instance (HasWidth a, HasWidth b) => HasWidth (Either a b) where
width = either width width
newtype Core = Core (Either (Chunk Text) (Height, Width))
deriving (Eq, Ord, Show)
instance HasWidth Core where
width (Core ei) = either width (width . snd) ei
instance HasHeight Core where
height (Core ei) = either height (height . fst) ei
newtype Rod = Rod (Either (Int, Radiant) (Chunk Text))
deriving (Eq, Ord, Show)
instance HasWidth Rod where
width (Rod ei) = case ei of
Left (i, _) -> max 0 i
Right c -> width c
data RodRows
= RodRowsWithHeight (Seq (Seq Rod))
| RodRowsNoHeight Int
deriving (Eq, Ord, Show)
instance HasHeight RodRows where
height (RodRowsWithHeight sq) = Seq.length sq
height (RodRowsNoHeight _) = 0
instance HasWidth RodRows where
width (RodRowsWithHeight sq) = F.foldl' max 0 . fmap (F.sum . fmap width) $ sq
width (RodRowsNoHeight i) = max 0 i
rodRowsFromCore :: Radiant -> Core -> RodRows
rodRowsFromCore bk (Core ei) = case ei of
Left ck -> RodRowsWithHeight . Seq.singleton
. Seq.singleton . Rod . Right $ ck
Right (Height h, Width w)
| h < 1 -> RodRowsNoHeight w
| otherwise -> RodRowsWithHeight . Seq.replicate h . Seq.singleton
. Rod . Left $ (w, bk)
chunksFromRodRows :: RodRows -> Seq (Seq (Chunk Text))
chunksFromRodRows rr = case rr of
RodRowsWithHeight sq -> fmap (|> chunk "\n") . fmap (fmap chunkFromRod) $ sq
where
chunkFromRod (Rod ei) = case ei of
Left (i, r) -> (chunk . X.replicate i $ " ") & back r
Right c -> c
RodRowsNoHeight _ -> Seq.empty
data Payload a = Payload (Alignment a) Radiant (Either RodRows Core)
deriving (Eq, Ord, Show)
instance HasWidth (Payload a) where
width (Payload _ _ ei) = width ei
instance HasHeight (Payload a) where
height (Payload _ _ ei) = height ei
addVerticalPadding
:: Box Horizontal
-> Seq RodRows
addVerticalPadding bx@(Box sqnce) = fmap eqlize sqnce
where
maxTop = above bx
maxBot = below bx
eqlize bhp@(Payload _ rd ei) = case ei of
Left rr -> eqlzeRodRows rr
Right cre -> eqlzeRodRows (rodRowsFromCore rd cre)
where
eqlzeRodRows rr = case rr of
RodRowsWithHeight sq -> RodRowsWithHeight $ tp w <> sq <> bot w
RodRowsNoHeight i
| maxTop + maxBot == 0 -> RodRowsNoHeight i
| otherwise -> RodRowsWithHeight $ tp w <> bot w
where
w = width rr
tp w = Seq.replicate (max 0 (maxTop above bhp)) (pad w)
bot w = Seq.replicate (max 0 (maxBot below bhp)) (pad w)
pad w = Seq.singleton . Rod . Left $ (w, rd)
horizontalMerge :: Seq RodRows -> RodRows
horizontalMerge sqn = case viewl sqn of
EmptyL -> RodRowsNoHeight 0
x :< xs -> case x of
RodRowsNoHeight i -> RodRowsNoHeight $ F.foldl' comb i xs
where
comb acc x' = case x' of
RodRowsNoHeight i' -> acc + i'
RodRowsWithHeight _ -> error "horizontalMerge: error 1"
RodRowsWithHeight sq -> RodRowsWithHeight $ F.foldl' comb sq xs
where
comb acc rr = case rr of
RodRowsWithHeight sq' -> Seq.zipWith (<>) acc sq'
RodRowsNoHeight _ -> error "horizontalMerge: error 2"
split :: Int -> (Int, Int)
split i = (r, r + rm)
where
(r, rm) = i `quotRem` 2
addHorizontalPadding
:: Box Vertical
-> Seq RodRows
addHorizontalPadding bx@(Box sqnce) = fmap eqlize sqnce
where
maxLeft = port bx
maxRight = starboard bx
eqlize (Payload a rd ei) = case ei of
Left rr -> addLeftRight rr
Right cre -> addLeftRight $ rodRowsFromCore rd cre
where
addLeftRight (RodRowsNoHeight _) = RodRowsNoHeight $ maxLeft + maxRight
addLeftRight (RodRowsWithHeight sq) = RodRowsWithHeight $
fmap addLeftRightToLine sq
addLeftRightToLine lin = padder lenLft <> lin <> padder lenRgt
where
lenLin = F.sum . fmap width $ lin
lenLft = case a of
Center -> maxLeft (fst . split $ lenLin)
NonCenter Port -> maxLeft
NonCenter Starboard -> maxLeft lenLin
lenRgt = case a of
Center -> maxRight (snd . split $ lenLin)
NonCenter Port -> maxRight lenLin
NonCenter Starboard -> maxRight
padder len
| len < 1 = Seq.empty
| otherwise = Seq.singleton . Rod . Left $ (len, rd)
verticalMerge :: Seq RodRows -> RodRows
verticalMerge sqnce = case viewl sqnce of
EmptyL -> RodRowsNoHeight 0
x :< xs -> F.foldl' comb x xs
where
comb acc rr = case (acc, rr) of
(RodRowsNoHeight w, RodRowsNoHeight _) -> RodRowsNoHeight w
(RodRowsNoHeight _, RodRowsWithHeight sq) -> RodRowsWithHeight sq
(RodRowsWithHeight sq, RodRowsNoHeight _) -> RodRowsWithHeight sq
(RodRowsWithHeight sq1, RodRowsWithHeight sq2) ->
RodRowsWithHeight $ sq1 <> sq2
newtype Box a = Box (Seq (Payload a))
deriving (Eq, Ord, Show)
instance Monoid (Box a) where
mempty = Box Seq.empty
mappend (Box x) (Box y) = Box (x <> y)
class Orientation a where
rodRows :: Box a -> RodRows
spacer :: Radiant -> Int -> Box a
spreader :: Alignment a -> Int -> Box a
instance Orientation Vertical where
rodRows = verticalMerge . addHorizontalPadding
spacer r i = Box . Seq.singleton $
Payload (NonCenter Port) r (Right . Core . Right $
(Height (max 0 i), Width 0))
spreader a i = Box . Seq.singleton $
Payload a mempty (Right . Core . Right $
(Height 0, Width (max 0 i)))
instance Orientation Horizontal where
rodRows = horizontalMerge . addVerticalPadding
spacer r i = Box . Seq.singleton $
Payload (NonCenter Top) r (Right . Core . Right $
(Height 0, Width (max 0 i)))
spreader a i = Box . Seq.singleton $
Payload a mempty (Right . Core . Right $
(Height (max 0 i), Width 0))
class LeftRight a where
port :: a -> Int
starboard :: a -> Int
class UpDown a where
above :: a -> Int
below :: a -> Int
instance LeftRight (Payload Vertical) where
port (Payload a _ ei) = case a of
NonCenter Port -> 0
NonCenter Starboard -> width ei
Center -> fst . split . width $ ei
starboard (Payload a _ s3) = case a of
NonCenter Port -> width s3
NonCenter Starboard -> 0
Center -> snd . split . width $ s3
instance UpDown (Payload Horizontal) where
above (Payload a _ s3) = case a of
NonCenter Top -> 0
NonCenter Bottom -> height s3
Center -> fst . split . height $ s3
below (Payload a _ s3) = case a of
NonCenter Top -> height s3
NonCenter Bottom -> 0
Center -> snd . split . height $ s3
instance LeftRight (Box Vertical) where
port (Box sq) = F.foldl' max 0 . fmap port $ sq
starboard (Box sq) = F.foldl' max 0 . fmap starboard $ sq
instance HasWidth (Box Vertical) where
width b = port b + starboard b
instance HasHeight (Box Vertical) where
height (Box sq) = F.sum . fmap height $ sq
instance UpDown (Box Horizontal) where
above (Box sq) = F.foldl' max 0 . fmap above $ sq
below (Box sq) = F.foldl' max 0 . fmap below $ sq
instance HasHeight (Box Horizontal) where
height b = above b + below b
instance HasWidth (Box Horizontal) where
width (Box sq) = F.sum . fmap width $ sq
fromChunk
:: Alignment a
-> Radiant
-> Chunk Text
-> Box a
fromChunk a r = Box . Seq.singleton . Payload a r . Right . Core . Left
blank
:: Alignment a
-> Radiant
-> Height
-> Width
-> Box a
blank a r h w =
Box . Seq.singleton . Payload a r . Right . Core . Right $ (h, w)
wrap
:: Orientation a
=> Alignment b
-> Radiant
-> Box a
-> Box b
wrap a r = Box . Seq.singleton . Payload a r . Left . rodRows
render :: Orientation a => Box a -> Seq (Chunk Text)
render = join . chunksFromRodRows . rodRows
data Cell = Cell
{ _rows :: Seq (Seq (Chunk Text))
, _horizontal :: Alignment Horizontal
, _vertical :: Alignment Vertical
, _background :: Radiant
} deriving (Eq, Ord, Show)
makeLenses ''Cell
instance Monoid Cell where
mempty = Cell mempty mempty mempty mempty
mappend (Cell rx hx vx bx) (Cell ry hy vy by)
= Cell (zipSeqs rx ry) (hx <> hy) (vx <> vy) (bx <> by)
where
zipSeqs x y = Seq.zipWith (<>) x' y'
where
x' = x <> Seq.replicate
(max 0 (Seq.length y Seq.length x)) Seq.empty
y' = y <> Seq.replicate
(max 0 (Seq.length x Seq.length y)) Seq.empty
separator :: Radiant -> Int -> Cell
separator rd i = Cell (Seq.singleton (Seq.singleton ck)) top left rd
where
ck = (chunk $ X.replicate (max 0 i) " ") & back rd
tableByRows :: Seq (Seq Cell) -> Box Vertical
tableByRows
= mconcatSeq
. fmap rowToBoxV
. fmap mconcatSeq
. fmap (fmap toBoxH)
. uncurry padBoxV
. addWidthMap
. fmap (fmap cellToBoxV)
. equalize mempty
rowToBoxV :: Box Horizontal -> Box Vertical
rowToBoxV = wrap center mempty
cellToBoxV :: Cell -> (Box Vertical, Alignment Horizontal, Radiant)
cellToBoxV (Cell rs ah av rd) = (bx, ah, rd)
where
bx = mconcatSeq
. fmap (wrap av rd)
. fmap (mconcatSeq . fmap (fromChunk top rd))
$ rs
toBoxH
:: (Box Vertical, Alignment Horizontal, Radiant)
-> Box Horizontal
toBoxH (bv, ah, rd) = wrap ah rd bv
addWidthMap
:: Seq (Seq (Box Vertical, b, c))
-> (M.Map Int (Int, Int), Seq (Seq (Box Vertical, b, c)))
addWidthMap sqnce = (m, sqnce)
where
m = widestCellMap . fmap (fmap (\(a, _, _) -> a)) $ sqnce
padBoxV
:: M.Map Int (Int, Int)
-> Seq (Seq (Box Vertical, a, b))
-> Seq (Seq (Box Vertical, a, b))
padBoxV mp = fmap (Seq.mapWithIndex f)
where
f idx (bx, a, b) = (bx <> padLeft <> padRight, a, b)
where
(lenL, lenR) = mp M.! idx
padLeft = spreader right lenL
padRight = spreader left lenR
widestCellMap :: Seq (Seq (Box Vertical)) -> M.Map Int (Int, Int)
widestCellMap = F.foldl' outer M.empty
where
outer mpOuter = Seq.foldlWithIndex inner mpOuter
where
inner mpInner idx bx = case M.lookup idx mpInner of
Nothing -> M.insert idx (port bx, starboard bx) mpInner
Just (pOld, sOld) -> M.insert idx
(max pOld (port bx), max sOld (starboard bx)) mpInner
tableByColumns :: Seq (Seq Cell) -> Box Horizontal
tableByColumns
= mconcatSeq
. fmap rowToBoxH
. fmap mconcatSeq
. fmap (fmap toBoxV)
. uncurry padBoxH
. addHeightMap
. fmap (fmap cellToBoxH)
. equalize mempty
rowToBoxH :: Box Vertical -> Box Horizontal
rowToBoxH = wrap top mempty
cellToBoxH :: Cell -> (Box Horizontal, Alignment Vertical, Radiant)
cellToBoxH (Cell rs ah av rd) = (bx, av, rd)
where
bx = wrap ah rd
. mconcatSeq
. fmap (wrap av rd)
. fmap (mconcatSeq . fmap (fromChunk top rd))
$ rs
addHeightMap
:: Seq (Seq (Box Horizontal, b, c))
-> (M.Map Int (Int, Int), Seq (Seq (Box Horizontal, b, c)))
addHeightMap sqnce = (m, sqnce)
where
m = tallestCellMap . fmap (fmap (\(a, _, _) -> a)) $ sqnce
tallestCellMap :: Seq (Seq (Box Horizontal)) -> M.Map Int (Int, Int)
tallestCellMap = F.foldl' outer M.empty
where
outer mpOuter = Seq.foldlWithIndex inner mpOuter
where
inner mpInner idx bx = case M.lookup idx mpInner of
Nothing -> M.insert idx (above bx, below bx) mpInner
Just (aOld, bOld) -> M.insert idx
(max aOld (above bx), max bOld (below bx)) mpInner
padBoxH
:: M.Map Int (Int, Int)
-> Seq (Seq (Box Horizontal, a, b))
-> Seq (Seq (Box Horizontal, a, b))
padBoxH mp = fmap (Seq.mapWithIndex f)
where
f idx (bx, a, b) = (bx <> padTop <> padBot, a, b)
where
(lenT, lenB) = mp M.! idx
padTop = spreader bottom lenT
padBot = spreader top lenB
toBoxV
:: (Box Horizontal, Alignment Vertical, Radiant)
-> Box Vertical
toBoxV (bh, av, rd) = wrap av rd bh
equalize :: a -> Seq (Seq a) -> Seq (Seq a)
equalize emp sqnce = fmap adder sqnce
where
maxLen = F.foldl' max 0 . fmap Seq.length $ sqnce
adder sq = sq <> pad
where
pad = Seq.replicate (max 0 (maxLen Seq.length sq)) emp
mconcatSeq :: Monoid a => Seq a -> a
mconcatSeq = F.foldl' (<>) mempty
intersperse :: a -> Seq a -> Seq a
intersperse new sq = case viewl sq of
EmptyL -> Seq.empty
x :< xs -> x <| go xs
where
go sqnce = case viewl sqnce of
EmptyL -> Seq.empty
a :< as -> new <| a <| go as