From f4930a40e3ae7af4c43c78f7062d34385153a891 Mon Sep 17 00:00:00 2001 From: tv Date: Sun, 8 Mar 2026 05:33:25 +0100 Subject: add semantic normalization tests; split test suite --- blessings.cabal | 6 +- test/BaseSpec.hs | 67 +++++++++++++++++ test/Main.hs | 1 + test/NormalizationSpec.hs | 179 ++++++++++++++++++++++++++++++++++++++++++++++ test/Spec.hs | 80 --------------------- 5 files changed, 252 insertions(+), 81 deletions(-) create mode 100644 test/BaseSpec.hs create mode 100644 test/Main.hs create mode 100644 test/NormalizationSpec.hs delete mode 100644 test/Spec.hs diff --git a/blessings.cabal b/blessings.cabal index 7622136..4d6e0d7 100644 --- a/blessings.cabal +++ b/blessings.cabal @@ -21,8 +21,12 @@ library test-suite test-blessings type: exitcode-stdio-1.0 - main-is: Spec.hs + main-is: Main.hs hs-source-dirs: test + other-modules: + BaseSpec + NormalizationSpec + default-language: GHC2024 ghc-options: -Wall build-depends: diff --git a/test/BaseSpec.hs b/test/BaseSpec.hs new file mode 100644 index 0000000..64ec920 --- /dev/null +++ b/test/BaseSpec.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE MultiWayIf #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module BaseSpec (spec) where + +import Blessings +import Control.Exception +import Data.Sequences qualified as S +import System.IO.Unsafe +import System.Timeout +import Test.Hspec +import Test.QuickCheck + +unsafeTimeout :: Int -> a -> a +unsafeTimeout n f = + case unsafePerformIO $ timeout n (evaluate f) of + Nothing -> error "timeout" + Just y -> y + +instance Arbitrary a => Arbitrary (Blessings a) where + arbitrary = + oneof + [ Plain <$> arbitrary + , pure Empty + , (<>) <$> arbitrary <*> arbitrary + , SGR <$> arbitrary <*> arbitrary + ] + +spec :: Spec +spec = + describe "Blessings" $ do + it "obeys the Semigroup laws" $ + property $ \(x :: Blessings String) y z -> + (x <> y) <> z == x <> (y <> z) + + it "obeys the Monoid laws" $ + property $ \(x :: Blessings String) -> + x <> mempty == x && x == mempty <> x + + it "splitAt produces pairs with elements of proper length" $ + property $ \(i :: Int, x :: Blessings String) -> + unsafeTimeout 100000 $ + let + (l, r) = S.splitAt i x + n = S.lengthIndex x + in + if | i <= 0 -> S.lengthIndex l == 0 && S.lengthIndex r == n + | i <= n -> S.lengthIndex l == i && S.lengthIndex r == n - i + | otherwise -> S.lengthIndex l == n && S.lengthIndex r == 0 + + let infx = mconcat (repeat (Plain "x" :: Blessings String)) + + it "can take from infinite structure" $ + property $ \(n :: NonNegative Int) -> + unsafeTimeout 100000 $ + let i = getNonNegative n in + S.lengthIndex (S.take i infx) == i + + it "can drop from infinite structure" $ + property $ \(n :: NonNegative Int) -> + unsafeTimeout 100000 $ + let i = getNonNegative n in + S.lengthIndex (S.take i (S.drop i infx)) == i + + it "can take concat of infinite structures" $ + property $ \(x :: Blessings String) -> + unsafeTimeout 100000 $ + S.lengthIndex (S.take 1 $ infx <> x) <= 1 diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 index 0000000..a824f8c --- /dev/null +++ b/test/Main.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} 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 diff --git a/test/Spec.hs b/test/Spec.hs deleted file mode 100644 index 32bd1e7..0000000 --- a/test/Spec.hs +++ /dev/null @@ -1,80 +0,0 @@ -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -import Blessings -import Control.Exception -import Data.Sequences qualified as S -import System.IO.Unsafe -import System.Timeout -import Test.Hspec -import Test.QuickCheck - -unsafeTimeout :: Int -> a -> a -unsafeTimeout n f = - case unsafePerformIO $ timeout n (evaluate f) of - Nothing -> error "timeout" - Just y -> y - -instance Arbitrary a => Arbitrary (Blessings a) where - arbitrary = - oneof - [ Plain <$> arbitrary - , pure Empty - , (<>) <$> arbitrary <*> arbitrary - , SGR <$> arbitrary <*> arbitrary - ] - -main :: IO () -main = - hspec $ do - describe "Blessings" $ do - it "obeys the Semigroup laws" $ - property $ \(x :: Blessings String) y z -> - (x <> y) <> z == x <> (y <> z) - - it "obeys the Monoid laws" $ - 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 (S.take 1 x <> S.drop 1 x) == normalize x - - it "uncurry (<>) (splitAt i x) == x" $ - property $ \(i :: Int, x :: Blessings String) -> - unsafeTimeout 100000 $ - normalize (uncurry (<>) (S.splitAt i x)) == normalize x - - it "splitAt produces pairs with elements of proper length" $ - property $ \(i :: Int, x :: Blessings String) -> - unsafeTimeout 100000 $ - let - (l, r) = S.splitAt i x - n = S.lengthIndex x - in - if | i <= 0 -> S.lengthIndex l == 0 && S.lengthIndex r == n - | i <= n -> S.lengthIndex l == i && S.lengthIndex r == n - i - | otherwise -> S.lengthIndex l == n && S.lengthIndex r == 0 - - let infx = mconcat (repeat (Plain "x" :: Blessings String)) - - it "can take from infinite structure" $ - property $ \(n :: NonNegative Int) -> - unsafeTimeout 100000 $ - let i = getNonNegative n in - S.lengthIndex (S.take i infx) == i - - it "can drop from infinite structure" $ - property $ \(n :: NonNegative Int) -> - unsafeTimeout 100000 $ - let i = getNonNegative n in - S.lengthIndex (S.take i (S.drop i infx)) == i - - it "can take concat of infinite structures" $ - property $ \(x :: Blessings String) -> - unsafeTimeout 100000 $ - S.lengthIndex (S.take 1 $ infx <> x) <= 1 -- cgit v1.2.3