add normalization

2 files changed, 98 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
diff --git a/test/Spec.hs b/test/Spec.hs
index f42712a..6cf4d2f 100644
--- a/test/Spec.hs
+++ b/test/Spec.hs
@@ -35,6 +35,14 @@ main =
         property $ \(x :: Blessings String) ->
           x <> mempty == x && x == mempty <> x
 
+      it "pp (normalize x) == pp x" $
+        property $ \(x :: Blessings String) ->
+          pp (stripSGR (normalize x)) == pp (stripSGR x)
+
+      it "take 1 x <> drop 1 x == x" $
+        property $ \(x :: Blessings String) ->
+          normalize (B.take 1 x <> B.drop 1 x) == normalize x
+
       let infx = mconcat (repeat (Plain "x" :: Blessings String))
 
       it "can take from infinite structure" $