module Language.Haskell.HBB.Internal.TTreeColor (
applyColoredTTree
) where
import Language.Haskell.HBB.Internal.SrcSpan
import Language.Haskell.HBB.Internal.TTree
import Control.Monad.State.Lazy
import Data.List (sortBy)
import SrcLoc
data TTreeColor = Gray
| Red | HlRed | Green | HlGreen
| Yellow | HlYellow | Blue | HlBlue
| Magenta | HlMagenta | Cyan | HlCyan
| DefaultWhiteOnBlack
additionColor = Gray
displayColors = cycle [ Red , Green , Yellow , Blue , Magenta , Cyan
, HlRed , HlGreen , HlYellow , HlBlue , HlMagenta , HlCyan ]
ansiColorStr :: TTreeColor -> String
ansiColorStr Gray = "\ESC[1;30m"
ansiColorStr Red = "\ESC[0;31m"
ansiColorStr Green = "\ESC[0;32m"
ansiColorStr Yellow = "\ESC[0;33m"
ansiColorStr Blue = "\ESC[0;34m"
ansiColorStr Magenta = "\ESC[0;35m"
ansiColorStr Cyan = "\ESC[0;36m"
ansiColorStr HlRed = "\ESC[1;31m"
ansiColorStr HlGreen = "\ESC[1;32m"
ansiColorStr HlYellow = "\ESC[1;33m"
ansiColorStr HlBlue = "\ESC[1;34m"
ansiColorStr HlMagenta = "\ESC[1;35m"
ansiColorStr HlCyan = "\ESC[1;36m"
ansiColorStr DefaultWhiteOnBlack = "\ESC[0m"
attachColors
:: (BufSpan,ClientTTree)
-> ((BufSpan,TTreeColor),TTree LineBuf (RealSrcSpan,Int) (BufSpan,TTreeColor))
attachColors tree =
let colorStep
:: (BufSpan,TTree LineBuf (RealSrcSpan,Int) BufSpan)
-> State (Int,[(RealSrcSpan,TTreeColor)]) ((BufSpan,TTreeColor),TTree LineBuf (RealSrcSpan,Int) (BufSpan,TTreeColor))
colorStep (l,(TTree content childs)) = do
childs' <- mapM colorStep childs
color <- case content of
(Display (spn,_)) -> do
(colorIdx,alreadyKnown) <- get
let (selectedColor,newState) = case filter (\(s,_) -> s == spn) alreadyKnown of
[] -> let color2add = (displayColors !! colorIdx)
in (color2add,(colorIdx+1,((spn,color2add):alreadyKnown)))
[(_,c)] -> (c,(colorIdx,alreadyKnown))
(_:_) -> error "internal error (more than one color for one src-span)"
put newState
return selectedColor
(Addition _) -> return additionColor
return $ ((l,color),(TTree content childs'))
in evalState (colorStep tree) (0,[])
applyColoredTTree ::
[(FilePath,LineBuf)]
-> (BufSpan,ClientTTree)
-> LineBuf
-> LineBuf
applyColoredTTree fc tree lns =
applyTTreeGeneric
(Just (DefaultWhiteOnBlack,(\(_,x) -> x),finFun))
fc
(\(s,_) -> s)
(attachColors tree)
lns
where
finFun :: (TTreeColor,(BufSpan,TTreeColor)) -> (LineBuf,LineBuf,LineBuf) -> (LineBuf,LineBuf,LineBuf)
finFun (parColor,(_,color)) (initLines,childsRes,traiLines) =
( initLines
,joinSplit ([ansiColorStr color],childsRes)
,joinSplit ([ansiColorStr parColor],traiLines))