diff options
Diffstat (limited to 'src/Blessings.hs')
| -rw-r--r-- | src/Blessings.hs | 285 |
1 files changed, 168 insertions, 117 deletions
diff --git a/src/Blessings.hs b/src/Blessings.hs index dba5e77..67eecad 100644 --- a/src/Blessings.hs +++ b/src/Blessings.hs @@ -269,6 +269,174 @@ sgrBColor (48:2:_) = Just 5 sgrBColor _ = Nothing +data Style = Style + { fg :: FColor + , bg :: BColor + , blink :: Blink + , bold :: Bold + , underline :: Underline + } + deriving (Eq, Show) + +defaultStyle :: Style +defaultStyle = + Style + { fg = ECMA48FColor 39 + , bg = ECMA48BColor 49 + , blink = NoBlink + , bold = NoBold + , underline = NoUnderline + } + + +-------------------------------------------------------------------------------- +-- Semantics +-------------------------------------------------------------------------------- + +type ColoredChar a = (Style, Element a) + +sem :: Blessable a => Blessings a -> [ColoredChar a] +sem = semWith defaultStyle + +semWith :: Blessable a => Style -> Blessings a -> [ColoredChar a] +semWith st = \case + Empty -> [] + Plain t -> [ (st, c) | c <- otoList t ] + Append a b -> semWith st a ++ semWith st b + SGR pm a -> + let st' = applyPm st pm + in semWith st' a + + +-------------------------------------------------------------------------------- +-- SGR interpretation +-------------------------------------------------------------------------------- + +-- apply a full SGR list to a Style +applyPm :: Style -> [Word8] -> Style +applyPm st pm = go st pm + where + go s [] = s + + -- reset + go _ (0:rest) = + go defaultStyle rest + + -- bold on/off + go s (1:rest) = go s{ bold = Bold } rest + go s (22:rest) = go s{ bold = NoBold } rest + + -- underline on/off + go s (4:rest) = go s{ underline = Underline } rest + go s (24:rest) = go s{ underline = NoUnderline } rest + + -- blink on/off + go s (5:rest) = go s{ blink = Blink } rest + go s (25:rest) = go s{ blink = NoBlink } rest + + -- 8-color fg + go s (c:rest) + | 30 <= c && c <= 37 || c == 39 = + go s{ fg = ECMA48FColor c } rest + + -- 8-color bg + go s (c:rest) + | 40 <= c && c <= 47 || c == 39 = + go s{ bg = ECMA48BColor c } rest + + -- xterm-256 fg: 38;5;i + go s (38:5:i:rest) = + go s{ fg = Xterm256FColor i } rest + + -- xterm-256 bg: 48;5;i + go s (48:5:i:rest) = + go s{ bg = Xterm256BColor i } rest + + -- truecolor fg: 38;2;r;g;b + go s (38:2:r:g:b:rest) = + go s{ fg = ISO8613_3FColor r g b } rest + + -- truecolor bg: 48;2;r;g;b + go s (48:2:r:g:b:rest) = + go s{ bg = ISO8613_3BColor r g b } rest + + -- anything else / incomplete sequences: skip + go s (_:rest) = go s rest + + +pmHasVisibleEffect :: Style -> [Word8] -> Bool +pmHasVisibleEffect st pm = + applyPm st pm /= st + + +-------------------------------------------------------------------------------- +-- Normalizer +-------------------------------------------------------------------------------- + +normalize :: Blessable a => Blessings a -> Blessings a +normalize = fromSem . sem + +fromSem :: Blessable a => [ColoredChar a] -> Blessings a +fromSem [] = Empty +fromSem cs = + foldr1 Append + [ chunkToBlessings st (S.fromList s) + | (st, s) <- chunks cs + , not (null s) + ] + +chunks :: Eq t => [(t, a)] -> [(t, [a])] +chunks [] = [] +chunks ((st0,c0):rest) = go st0 [c0] rest + where + go curSt acc [] = + [(curSt, L.reverse acc)] + go curSt acc ((st,c):xs) + | st == curSt = go curSt (c:acc) xs + | otherwise = (curSt, L.reverse acc) : go st [c] xs + +chunkToBlessings :: Blessable a => Style -> a -> Blessings a +chunkToBlessings st s + | s == mempty = Empty + | st == defaultStyle = Plain s + | otherwise = SGR (styleToPm st) (Plain s) + +styleToPm :: Style -> [Word8] +styleToPm st = + fgCodes ++ bgCodes ++ blinkCodes ++ boldCodes ++ underlineCodes + where + fgCodes = + case fg st of + ECMA48FColor c -> [c] + Xterm256FColor i -> [38,5,i] + ISO8613_3FColor r g b -> [38,2,r,g,b] + + bgCodes = + case bg st of + ECMA48BColor c -> [c] + Xterm256BColor i -> [48,5,i] + ISO8613_3BColor r g b -> [48,2,r,g,b] + + blinkCodes = + case blink st of + Blink -> [5] + NoBlink -> [] + + boldCodes = + case bold st of + Bold -> [1] + NoBold -> [] + + underlineCodes = + case underline st of + Underline -> [4] + NoUnderline -> [] + + +-------------------------------------------------------------------------------- +-- Renderer +-------------------------------------------------------------------------------- + type RenderState = [(FColor, BColor, Blink, Bold, Underline)] @@ -315,123 +483,6 @@ renderSGR pm = "\ESC[" <> mconcat (L.intersperse ";" (map (fromString . show) pm)) <> "m" -stripSGR :: Blessings a -> Blessings a -stripSGR = \case - Append t1 t2 -> Append (stripSGR t1) (stripSGR t2) - SGR _ t -> stripSGR t - Plain x -> Plain x - Empty -> Empty - - -normalize' :: (Eq a, Monoid a) => Blessings a -> Blessings a -> Blessings a -normalize' t t' = - if t' == t - then t - else normalize t' - - -normalize :: (Eq a, Monoid a) => Blessings a -> Blessings a -normalize = \case - Append Empty t -> normalize t - Append t Empty -> normalize t - Append (Append t1 t2) t3 -> normalize $ Append t1 (Append t2 t3) - Append (Plain s1) (Plain s2) -> normalize $ Plain (s1 <> s2) - - Append (Plain s1) (Append (Plain s2) t1) -> - normalize (Append (Plain (s1 <> s2)) t1) - - t@(Append t1@(SGR pm1 t11) t2@(Append (SGR pm2 t21) t22)) -> - let - pm1' = normalizePm pm1 - pm2' = normalizePm pm2 - in - if pm1' == pm2' - then normalize (Append (SGR pm1 (Append t11 t21)) t22) - else normalize' t $ Append (normalize t1) (normalize t2) - - t@(Append t1@(SGR pm1 t11) t2@(SGR pm2 t21)) -> - let - pm1' = normalizePm pm1 - pm2' = normalizePm pm2 - in - if pm1' == pm2' - then normalize (SGR pm1' (Append t11 t21)) - else normalize' t $ Append (normalize t1) (normalize t2) - - t@(Append t1 t2) -> normalize' t $ Append (normalize t1) (normalize t2) - SGR _ Empty -> Empty - SGR [] t -> normalize t - t@(SGR pm t1) -> normalize' t $ SGR (normalizePm pm) (normalize t1) - Plain x | x == mempty -> Empty - t@(Plain _) -> t - Empty -> Empty - - -normalizeHead :: (Eq a, Monoid a) => Blessings a -> Blessings a -normalizeHead = \case - Append Empty t -> normalizeHead t - Append t1 t2 -> - let - t1' = normalizeHead t1 - in - if t1' == Empty - then normalizeHead t2 - else Append t1' t2 - SGR _ Empty -> Empty - SGR [] t -> normalizeHead t - SGR pm t -> - let - pm' = normalizePm pm - t' = normalizeHead t - in - if pm' == [] - then t' - else SGR pm' t' - Plain x | x == mempty -> Empty - t@(Plain _) -> t - Empty -> Empty - - -data NormalizedPm - = NormalizedPm - { foregroundColor :: [Word8] - , backgroundColor :: [Word8] - } - -emptyNormalizedPm :: NormalizedPm -emptyNormalizedPm - = NormalizedPm - { foregroundColor = [] - , backgroundColor = [] - } - -normalizePm :: [Word8] -> [Word8] -normalizePm pm0 = - collectEffective emptyNormalizedPm $ skipCanceled pm0 pm0 - where - collectEffective p = \case - -- direct-color - (38 : 2 : r : g : b : pm) -> collectEffective (p { foregroundColor = [38, 2, r, g, b] }) pm - (48 : 2 : r : g : b : pm) -> collectEffective (p { backgroundColor = [48, 2, r, g, b] }) pm - -- indexed-color - (38 : 5 : i : pm) -> collectEffective (p { foregroundColor = [38, 5, i] }) pm - (48 : 5 : i : pm) -> collectEffective (p { backgroundColor = [48, 5, i] }) pm - (ps : pm) - -- 8-color (must be analyzed after direct- and indexed-colors) - | 30 <= ps && ps <= 39 -> collectEffective (p { foregroundColor = [ps] }) pm - | 40 <= ps && ps <= 49 -> collectEffective (p { backgroundColor = [ps] }) pm - -- ignore everything else - | otherwise -> ps : collectEffective p pm - [] -> foregroundColor p <> backgroundColor p - - skipCanceled xs = \case - (38 : 2 : _ : _ : _ : pm) -> skipCanceled xs pm - (38 : 5 : _ : pm) -> skipCanceled xs pm - xs'@(0 : pm) -> skipCanceled xs' pm - (_ : pm) -> skipCanceled xs pm - [] -> xs - - pp :: Blessable a => Blessings a -> a pp t = render emptyRenderState t mempty |