diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Blessings.hs | 96 |
1 files changed, 90 insertions, 6 deletions
diff --git a/src/Blessings.hs b/src/Blessings.hs index 559db3e..8b55e24 100644 --- a/src/Blessings.hs +++ b/src/Blessings.hs @@ -264,11 +264,95 @@ stripSGR = \case 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 + + +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 "" -instance Blessable a => Blessable (Blessings a) where +instance (Eq a, Blessable a) => Blessable (Blessings a) where length (Plain x) = Bless.length x length (SGR _ t) = Bless.length t length (Append t1 t2) = Bless.length t1 + Bless.length t2 @@ -287,9 +371,9 @@ instance Blessable a => Blessable (Blessings a) where then t2' else Append t1' t2' Plain s -> - Plain (Bless.drop n s) + normalize $ Plain (Bless.drop n s) SGR pm t -> - SGR pm (Bless.drop n t) + normalize $ SGR pm (Bless.drop n t) Empty -> Empty @@ -303,15 +387,15 @@ instance Blessable a => Blessable (Blessings a) where then t1' <> Bless.take n' t2 else t1' Plain s -> - Plain (Bless.take n s) + normalize $ Plain (Bless.take n s) SGR pm t -> - SGR pm (Bless.take n t) + normalize $ SGR pm (Bless.take n t) Empty -> Empty intercalate i = \case [] -> mempty [t] -> t - (t:ts) -> t <> i <> Bless.intercalate i ts + (t:ts) -> normalize $ t <> i <> Bless.intercalate i ts fromWord8 = Plain . Bless.fromWord8 |