move from syntactic to semantic normalization

Replace the old rewrite‑based normalizer with a semantic pass that
flattens 'Blessings' via 'sem' and reconstructs a canonical form.
This removes the need for ad‑hoc cleanup logic and guarantees
idempotent, minimal, and predictable normalization.

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