From f4930a40e3ae7af4c43c78f7062d34385153a891 Mon Sep 17 00:00:00 2001
From: tv <tv@krebsco.de>
Date: Sun, 8 Mar 2026 05:33:25 +0100
Subject: add semantic normalization tests; split test suite

---
 test/NormalizationSpec.hs | 179 ++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 179 insertions(+)
 create mode 100644 test/NormalizationSpec.hs

(limited to 'test/NormalizationSpec.hs')

diff --git a/test/NormalizationSpec.hs b/test/NormalizationSpec.hs
new file mode 100644
index 0000000..f73dd3b
--- /dev/null
+++ b/test/NormalizationSpec.hs
@@ -0,0 +1,179 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module NormalizationSpec (spec) where
+
+import Test.Hspec
+import Test.QuickCheck
+import Data.Word (Word8)
+
+import Blessings
+
+--------------------------------------------------------------------------------
+-- Arbitrary instances
+--------------------------------------------------------------------------------
+
+instance Arbitrary FColor where
+  arbitrary =
+    oneof
+      [ ECMA48FColor <$> elements ([30..37] <> [90..97] <> [39])
+      , Xterm256FColor <$> arbitrary
+      , ISO8613_3FColor <$> arbitrary <*> arbitrary <*> arbitrary
+      ]
+
+instance Arbitrary BColor where
+  arbitrary =
+    oneof
+      [ ECMA48BColor <$> elements ([40..47] <> [49])
+      , Xterm256BColor <$> arbitrary
+      , ISO8613_3BColor <$> arbitrary <*> arbitrary <*> arbitrary
+      ]
+
+instance Arbitrary Blink where
+  arbitrary = elements [Blink, NoBlink]
+
+instance Arbitrary Bold where
+  arbitrary = elements [Bold, NoBold]
+
+instance Arbitrary Underline where
+  arbitrary = elements [Underline, NoUnderline]
+
+instance Arbitrary Style where
+  arbitrary =
+    Style <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
+
+instance Arbitrary (Blessings String) where
+  arbitrary = sized genBlessings
+    where
+      genBlessings 0 =
+        oneof
+          [ pure Empty
+          , Plain <$> arbitrary
+          ]
+      genBlessings n =
+        oneof
+          [ pure Empty
+          , Plain <$> arbitrary
+          , SGR <$> arbitraryPm <*> genBlessings (n `div` 2)
+          , Append <$> genBlessings (n `div` 2) <*> genBlessings (n `div` 2)
+          ]
+
+      arbitraryPm :: Gen [Word8]
+      arbitraryPm = listOf arbitrary
+
+  shrink = shrinkBlessings
+
+shrinkBlessings :: Blessings String -> [Blessings String]
+shrinkBlessings = \case
+  Empty        -> []
+  Plain s      -> Empty : [ Plain s' | s' <- shrink s ]
+  SGR pm a     ->
+    [a] <>
+    [ SGR pm' a | pm' <- shrinkList (const []) pm ] <>
+    [ SGR pm a' | a' <- shrinkBlessings a ]
+  Append a b   ->
+    [a, b] <>
+    [ Append a' b | a' <- shrinkBlessings a ] <>
+    [ Append a b' | b' <- shrinkBlessings b ]
+
+--------------------------------------------------------------------------------
+-- Helpers
+--------------------------------------------------------------------------------
+
+allSgrNodes :: Blessings String -> [(Style, [Word8])]
+allSgrNodes = go defaultStyle
+  where
+    go :: Style -> Blessings String -> [(Style, [Word8])]
+    go st = \case
+      Empty      -> []
+      Plain _    -> []
+      Append a b -> go st a ++ go st b
+      SGR pm a   ->
+        let st' = applyPm st pm
+        in (st, pm) : go st' a
+
+allPm :: Blessings String -> [[Word8]]
+allPm = \case
+  Empty      -> []
+  Plain _    -> []
+  Append a b -> allPm a ++ allPm b
+  SGR pm a   -> pm : allPm a
+
+size :: Blessings String -> Int
+size = \case
+  Empty      -> 1
+  Plain _    -> 1
+  SGR _ a    -> 1 + size a
+  Append a b -> 1 + size a + size b
+
+--------------------------------------------------------------------------------
+-- Properties
+--------------------------------------------------------------------------------
+
+prop_normalize_preserves_sem :: Blessings String -> Bool
+prop_normalize_preserves_sem x =
+  sem (normalize x) == sem x
+
+prop_normalize_idempotent :: Blessings String -> Bool
+prop_normalize_idempotent x =
+  normalize (normalize x) == normalize x
+
+prop_no_unproductive_sgrs :: Blessings String -> Bool
+prop_no_unproductive_sgrs x =
+  all productive (allSgrNodes (normalize x))
+  where
+    productive (st, pm) = pmHasVisibleEffect st pm
+
+prop_sgr_params_canonical :: Blessings String -> Bool
+prop_sgr_params_canonical x =
+  all (\pm -> pm == normalizePm pm) (allPm (normalize x))
+  where
+    normalizePm pm = styleToPm (applyPm defaultStyle pm)
+
+prop_no_resets :: Blessings String -> Bool
+prop_no_resets x =
+  all (not . elem 0) (allPm (normalize x))
+
+prop_pmHasVisibleEffect_correct :: Style -> [Word8] -> Bool
+prop_pmHasVisibleEffect_correct st pm =
+  pmHasVisibleEffect st pm == (applyPm st pm /= st)
+
+prop_normalize_shrinks_or_equal :: Blessings String -> Bool
+prop_normalize_shrinks_or_equal x =
+  size (normalize x) <= size x
+
+prop_append_sem_associative
+  :: Blessings String -> Blessings String -> Blessings String -> Bool
+prop_append_sem_associative a b c =
+  sem (Append (Append a b) c) == sem (Append a (Append b c))
+
+--------------------------------------------------------------------------------
+-- Test runner
+--------------------------------------------------------------------------------
+
+spec :: Spec
+spec = do
+  describe "normalize" $ do
+    it "preserves semantics" $
+      property prop_normalize_preserves_sem
+
+    it "is idempotent" $
+      property prop_normalize_idempotent
+
+    it "never increases size" $
+      property prop_normalize_shrinks_or_equal
+
+    it "removes all unproductive SGRs" $
+      property prop_no_unproductive_sgrs
+
+    it "produces canonical SGR parameter lists" $
+      property prop_sgr_params_canonical
+
+    it "produces no resets" $
+      property prop_no_resets
+
+  describe "SGR semantics" $ do
+    it "pmHasVisibleEffect matches style change" $
+      property prop_pmHasVisibleEffect_correct
+
+  describe "Append" $ do
+    it "is associative under semantics" $
+      property prop_append_sem_associative
-- 
cgit v1.2.3