module Rasa.Ext.Slate.Internal.Attributes where
import Rasa.Ext
import qualified Yi.Rope as Y
import qualified Graphics.Vty as V
import Data.Bifunctor
convertStyle :: Style -> V.Attr
convertStyle (Style (fg', bg', flair')) = V.Attr
(maybe V.KeepCurrent convertFlair flair')
(maybe V.KeepCurrent convertColor fg')
(maybe V.KeepCurrent convertColor bg')
convertFlair :: Flair -> V.MaybeDefault V.Style
convertFlair Standout = V.SetTo V.standout
convertFlair Underline = V.SetTo V.underline
convertFlair ReverseVideo = V.SetTo V.reverseVideo
convertFlair Blink = V.SetTo V.blink
convertFlair Dim = V.SetTo V.dim
convertFlair Bold = V.SetTo V.bold
convertFlair DefFlair = V.Default
convertColor :: Color -> V.MaybeDefault V.Color
convertColor Black = V.SetTo V.black
convertColor Red = V.SetTo V.red
convertColor Green = V.SetTo V.green
convertColor Yellow = V.SetTo V.yellow
convertColor Blue = V.SetTo V.blue
convertColor Magenta = V.SetTo V.magenta
convertColor Cyan = V.SetTo V.cyan
convertColor White = V.SetTo V.white
convertColor DefColor = V.Default
reset :: V.Image
reset = V.text' V.defAttr ""
newtype AttrMonoid = AttrMonoid {
getAttr :: V.Attr
}
instance Monoid AttrMonoid where
mempty = AttrMonoid V.defAttr
AttrMonoid v `mappend` AttrMonoid v' = AttrMonoid $ v `mappend` v'
applyAttrs :: RenderInfo -> V.Image
applyAttrs (RenderInfo txt styles) = textAndStylesToImage mergedSpans (padSpaces <$> Y.lines txt)
where mergedSpans = second getAttr <$> combineSpans (fmap AttrMonoid <$> atts)
padSpaces = (`Y.append` " ")
atts = second convertStyle <$> styles
textAndStylesToImage :: [(Coord, V.Attr)] -> [Y.YiString] -> V.Image
textAndStylesToImage atts lines' = V.vertCat $ wrapResets . uncurry attrLine <$> pairLines atts lines'
where
wrapResets img = reset V.<|> img V.<|> reset
attrLine :: [(Coord, V.Attr)] -> Y.YiString -> V.Image
attrLine [] txt = plainText txt
attrLine atts "" = V.text' (mconcat (snd <$> atts)) ""
attrLine ((Coord _ 0, attr):atts) txt = V.text' attr "" V.<|> attrLine atts txt
attrLine atts@((Coord _ col, _):_) txt =
let (prefix, suffix) = Y.splitAt col txt
in plainText prefix V.<|> attrLine (decrCol col atts) suffix
pairLines :: [(Coord, b)] -> [a] -> [([(Coord, b)], a)]
pairLines _ [] = []
pairLines [] ls = zip (repeat []) ls
pairLines crds@((Coord 0 _, _):_) (l:ls) = (takeWhile isSameRow crds, l) : pairLines (decrRow $ dropWhile isSameRow crds) ls
where isSameRow (Coord 0 _, _) = True
isSameRow _ = False
pairLines crds (l:ls) = ([], l): pairLines (decrRow crds) ls
decrRow :: [(Coord, a)] -> [(Coord, a)]
decrRow = fmap (\(Coord r c, a) -> (Coord (r1) c, a))
decrCol :: Int -> [(Coord, a)] -> [(Coord, a)]
decrCol n = fmap (\(Coord r c, a) -> (Coord r (cn), a))
plainText :: Y.YiString -> V.Image
plainText = V.text' V.currentAttr . Y.toText