summaryrefslogtreecommitdiffstats
path: root/test
diff options
context:
space:
mode:
Diffstat (limited to 'test')
-rw-r--r--test/BaseSpec.hs (renamed from test/Spec.hs)21
-rw-r--r--test/Main.hs1
-rw-r--r--test/NormalizationSpec.hs179
3 files changed, 184 insertions, 17 deletions
diff --git a/test/Spec.hs b/test/BaseSpec.hs
index 32bd1e7..64ec920 100644
--- a/test/Spec.hs
+++ b/test/BaseSpec.hs
@@ -1,6 +1,7 @@
{-# LANGUAGE MultiWayIf #-}
-{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
+module BaseSpec (spec) where
+
import Blessings
import Control.Exception
import Data.Sequences qualified as S
@@ -24,9 +25,8 @@ instance Arbitrary a => Arbitrary (Blessings a) where
, SGR <$> arbitrary <*> arbitrary
]
-main :: IO ()
-main =
- hspec $ do
+spec :: Spec
+spec =
describe "Blessings" $ do
it "obeys the Semigroup laws" $
property $ \(x :: Blessings String) y z ->
@@ -36,19 +36,6 @@ 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 (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 $
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
generated by cgit v1.2.3 (git 2.25.1) at 2026-03-16 20:00:26 +0000