diff options
| -rw-r--r-- | blessings.cabal | 66 | ||||
| -rw-r--r-- | src/Blessings.hs | 362 | ||||
| -rw-r--r-- | src/Blessings/Internal.hs | 12 | ||||
| -rw-r--r-- | src/Blessings/Seq2.hs | 78 | ||||
| -rw-r--r-- | src/Blessings/String.hs | 18 | ||||
| -rw-r--r-- | src/Blessings/Text.hs | 18 | ||||
| -rw-r--r-- | test/BaseSpec.hs | 67 | ||||
| -rw-r--r-- | test/Main.hs | 1 | ||||
| -rw-r--r-- | test/NormalizationSpec.hs | 179 | ||||
| -rw-r--r-- | test/Spec.hs | 25 |
10 files changed, 677 insertions, 149 deletions
diff --git a/blessings.cabal b/blessings.cabal index 4b1570a..696bbc2 100644 --- a/blessings.cabal +++ b/blessings.cabal @@ -1,33 +1,43 @@ -author: tv -build-type: Simple -cabal-version: >= 1.8 -license: MIT -name: blessings -version: 2.1.0 +cabal-version: 3.0 +name: blessings +version: 3.0.0 +license: MIT +author: tv +build-type: Simple + +source-repository head + type: git + location: https://cgit.krebsco.de/blessings library - build-depends: - base, - text - exposed-modules: - Blessings, - Blessings.Internal, - Blessings.String, - Blessings.Text - ghc-options: -O2 -Wall - hs-source-dirs: src + exposed-modules: + Blessings + Blessings.Seq2 + + hs-source-dirs: src + default-language: GHC2024 + ghc-options: -Wall -Wextra + build-depends: + base, + dlist, + extra, + mono-traversable, + seq2, + text test-suite test-blessings - build-depends: - base, - blessings, - hspec, - QuickCheck - ghc-options: -Wall - hs-source-dirs: test - main-is: Spec.hs - type: exitcode-stdio-1.0 + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test + other-modules: + BaseSpec + NormalizationSpec -source-repository head - location: https://cgit.krebsco.de/blessings - type: git + default-language: GHC2024 + ghc-options: -Wall + build-depends: + base, + blessings, + hspec, + mono-traversable, + QuickCheck diff --git a/src/Blessings.hs b/src/Blessings.hs index 26a0666..e860b1d 100644 --- a/src/Blessings.hs +++ b/src/Blessings.hs @@ -1,21 +1,28 @@ -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} -module Blessings - ( module Export - , module Blessings - ) where +module Blessings where -import Blessings.Internal as Export (Blessable) -import qualified Blessings.Internal as Bless import Control.Applicative import Data.Ix (inRange) import Data.List (genericDrop) +import Data.List qualified as L +import Data.MonoTraversable (Element, GrowingAppend, MonoFoldable(..), MonoFunctor(..), MonoPointed(..), MonoTraversable(..)) +import Data.Sequences (Index, IsSequence, SemiSequence(..)) +import Data.Sequences qualified as S import Data.String +import Data.Tuple.Extra (both, first, second) import Data.Word (Word8) -import qualified Prelude -import Prelude hiding (drop, length, take) + + +type Blessable t = + ( Eq t + , IsString t + , Monoid t + , IsSequence t + , Index t ~ Int + ) type Ps = Word8 type Pm = [Ps] @@ -28,6 +35,15 @@ data Blessings a deriving (Eq, Show) +cataBlessings :: Monoid a => (a -> r) -> (Pm -> r -> r) -> (r -> r -> r) -> Blessings a -> r +cataBlessings plain sgr append = go + where + go (Plain s) = plain s + go (SGR pm t) = sgr pm (go t) + go (Append t1 t2) = append (go t1) (go t2) + go Empty = plain mempty + + instance Foldable Blessings where foldMap f = \case Append t1 t2 -> foldMap f t1 <> foldMap f t2 @@ -47,19 +63,74 @@ instance Functor Blessings where instance Semigroup (Blessings a) where t <> Empty = t Empty <> t = t - Append t1 t2 <> Append t3 t4 = t1 <> t2 <> t3 <> t4 - Append t1 t2 <> t3 = t1 <> t2 <> t3 + Append t1 t2 <> t3 = Append t1 (t2 <> t3) t1 <> t2 = Append t1 t2 instance Monoid (Blessings a) where mempty = Empty + mconcat = \case + x:[] -> x + x:xs -> Append x $ mconcat xs + [] -> Empty instance IsString a => IsString (Blessings a) where fromString = Plain . fromString +type instance Element (Blessings a) = a + +instance MonoFoldable (Blessings a) + +instance MonoPointed (Blessings a) where + opoint = Plain + +instance MonoFunctor (Blessings a) where + omap = fmap + +instance MonoTraversable (Blessings a) where + otraverse f = \case + Plain a -> Plain <$> f a + SGR pm t -> SGR pm <$> otraverse f t + Append t1 t2 -> Append <$> otraverse f t1 <*> otraverse f t2 + Empty -> pure Empty + +instance GrowingAppend (Blessings a) + +instance Blessable a => SemiSequence (Blessings a) where + type Index (Blessings a) = Int + + cons a b + | a == mempty = b + cons a (Plain b) = Plain (a <> b) + cons a Empty = Plain a + cons a b = Append (Plain a) b + + snoc b a + | a == mempty = b + snoc (Plain b) a = Plain (b <> a) + snoc Empty a = Plain a + snoc b a = Append b (Plain a) + + intersperse sep xs = + case otoList xs of + [] -> Empty + (y:ys) -> + foldl' + (\acc z -> snoc (snoc acc sep) z) + (Plain y) + ys + + find p = ofoldr (\x acc -> if p x then Just x else acc) Nothing + + sortBy cmp xs = + foldr cons Empty (L.sortBy cmp (otoList xs)) + + reverse xs = + foldr cons Empty (L.reverse (otoList xs)) + + class IsPm a where toPm :: a -> Pm fromPm :: Pm -> Maybe a @@ -151,8 +222,8 @@ instance IsPm Underline where rec xs = case filter (`elem` ([4,24] :: [Word8])) xs of [] -> Nothing xs' -> case last xs' of - 1 -> Just Underline - 22 -> Just NoUnderline + 4 -> Just Underline + 24 -> Just NoUnderline _ -> error "filter broken in fromPm :: Pm -> Maybe Underline" @@ -207,6 +278,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)] @@ -214,7 +453,7 @@ emptyRenderState :: RenderState emptyRenderState = [(ECMA48FColor 39, ECMA48BColor 49, NoBlink, NoBold, NoUnderline)] -render :: (Blessable a) => RenderState -> Blessings a -> a -> a +render :: Blessable a => RenderState -> Blessings a -> a -> a render _ (Plain s) y = s <> y @@ -247,59 +486,86 @@ render r (Append t1 t2) y = render _ Empty y = y -renderSGR :: (Blessable a) => Pm -> a +renderSGR :: Blessable a => Pm -> a renderSGR [] = mempty renderSGR pm = - ("\ESC["<>) . (<>"m") . Bless.intercalate ";" . map Bless.fromWord8 $ 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 +pp :: Blessable a => Blessings a -> a +pp t = render emptyRenderState t mempty -pp :: (Blessable a) => Blessings a -> a -pp t = render emptyRenderState t "" - - -instance 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 - length Empty = 0 +instance Blessable a => IsSequence (Blessings a) where + lengthIndex = ofoldl' (\acc w -> acc + S.lengthIndex w) 0 drop n = \case Append t1 t2 -> - case compare n (Bless.length t1) of - LT -> Bless.drop n t1 <> t2 - EQ -> t2 - GT -> Bless.drop (n - Bless.length t1) t2 + let + n1 = S.lengthIndex (S.take n t1) + n2 = n - n1 + t1' = S.drop n1 t1 + t2' = S.drop n2 t2 + in + Append t1' t2' Plain s -> - Plain (Bless.drop n s) + Plain (S.drop n s) SGR pm t -> - SGR pm (Bless.drop n t) + SGR pm (S.drop n t) Empty -> Empty take n = \case Append t1 t2 -> - case compare n (Bless.length t1) of - LT -> Bless.take n t1 - EQ -> t1 - GT -> t1 <> Bless.take (n - Bless.length t1) t2 + let + t1' = S.take n t1 + n' = n - S.lengthIndex t1' + in + if n' > 0 + then t1' <> S.take n' t2 + else t1' Plain s -> - Plain (Bless.take n s) + Plain (S.take n s) SGR pm t -> - SGR pm (Bless.take n t) + SGR pm (S.take n t) Empty -> Empty - intercalate i = \case - [] -> mempty - [t] -> t - (t:ts) -> t <> i <> Bless.intercalate i ts + splitAt n = \case + Append t1 t2 -> + let + nt1 = S.lengthIndex t1 + in + if n <= nt1 + then second (<>t2) $ S.splitAt n t1 + else first (t1<>) $ S.splitAt (n - nt1) t2 + Plain s -> + both Plain $ S.splitAt n s + SGR pm t -> + both (SGR pm) $ S.splitAt n t + Empty -> + (Empty, Empty) + + break p = \case + Append t1 t2 -> + case S.break p t1 of + (t1l, t1r) + | t1r == mempty -> first (t1l<>) $ S.break p t2 + | otherwise -> (t1l, t1r <> t2) + Plain s + | p s -> (Empty, Plain s) + | otherwise -> (Plain s, Empty) + SGR pm t -> + both (SGR pm) $ S.break p t + Empty -> + (Empty, Empty) + - fromWord8 = Plain . Bless.fromWord8 +chunksOf :: Blessable a => Int -> a -> [a] +chunksOf k = rec + where + rec t = + case S.splitAt k t of + (tl, tr) + | tl == mempty -> [] + | otherwise -> tl : rec tr diff --git a/src/Blessings/Internal.hs b/src/Blessings/Internal.hs deleted file mode 100644 index 0ed5556..0000000 --- a/src/Blessings/Internal.hs +++ /dev/null @@ -1,12 +0,0 @@ -module Blessings.Internal where - -import Data.String (IsString) -import Data.Word (Word8) - - -class (IsString a, Monoid a) => Blessable a where - length :: a -> Int - drop :: Int -> a -> a - take :: Int -> a -> a - intercalate :: a -> [a] -> a - fromWord8 :: Word8 -> a diff --git a/src/Blessings/Seq2.hs b/src/Blessings/Seq2.hs new file mode 100644 index 0000000..69e41ae --- /dev/null +++ b/src/Blessings/Seq2.hs @@ -0,0 +1,78 @@ +{-# OPTIONS_GHC -Wno-orphans #-} +{-# LANGUAGE TypeFamilies #-} +module Blessings.Seq2 where + +import Blessings +import Data.DList qualified as D +import Data.Seq2 +import Data.Text (Text) +import Data.Text qualified as T + + +instance Seq2 Blessings Text where + type Element Text = Char + split2 = split2By (not . T.null) T.split + + +split2By :: (Monoid a) => (a -> Bool) -> (t -> a -> [a]) -> t -> Blessings a -> [Blessings a] +split2By isNonEmpty split p = finalize . cataBlessings algPlain algSGR algAppend + where + + ------------------------------------------------------------------ + -- Accumulator: + -- + -- Nothing = no chunks + -- Just (open, front, last) = front ++ [last] + -- + -- front :: DList (Blessings Text) = all chunks except the last + -- last :: Blessings Text = last chunk + ------------------------------------------------------------------ + + finalize Nothing = [] + finalize (Just (_, f, l)) = D.toList f ++ [l] + + algPlain t = + case split p t of + -- [] -> undefined -- Data.Text.split returned [] + [x] -> + Just ( isNonEmpty x + , D.empty + , Plain x + ) + xs -> + Just ( isNonEmpty (last xs) + , D.fromList (map Plain (init xs)) + , Plain (last xs) + ) + + algSGR _ Nothing = Nothing + algSGR s (Just (o, f, l)) = + Just ( o + , D.map (SGR s) f + , SGR s l + ) + + algAppend Nothing r = r + algAppend l Nothing = l + algAppend (Just (ox, fx, lx)) (Just (oy, fy, ly)) + | ox && oy = mergeOpen fx lx fy ly oy + | otherwise = noMerge fx lx fy ly oy + + mergeOpen fx lx fy ly oy = + case fy of + D.Nil -> + Just (oy, fx, Append lx ly) + + D.Cons f fs -> + Just ( oy + , fx `D.snoc` Append lx f `D.append` D.fromList fs + , ly + ) + + _ -> undefined -- impossible since all DList are constructed safely + + noMerge fx lx fy ly oy = + Just ( oy + , fx `D.snoc` lx `D.append` fy + , ly + ) diff --git a/src/Blessings/String.hs b/src/Blessings/String.hs deleted file mode 100644 index 005cd7b..0000000 --- a/src/Blessings/String.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Blessings.String - ( module Blessings - ) where - -import Blessings -import Blessings.Internal -import qualified Data.List as L - - -instance Blessable String where - length = L.length - drop = L.drop - take = L.take - intercalate = L.intercalate - fromWord8 = show diff --git a/src/Blessings/Text.hs b/src/Blessings/Text.hs deleted file mode 100644 index 1f82c22..0000000 --- a/src/Blessings/Text.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Blessings.Text - ( module Blessings - ) where - -import Blessings -import Blessings.Internal -import Data.Text (Text) -import qualified Data.Text as T - - -instance Blessable Text where - length = T.length - drop = T.drop - take = T.take - intercalate = T.intercalate - fromWord8 = T.pack . show 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 298eb04..0000000 --- a/test/Spec.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -import Test.QuickCheck -import Test.Hspec -import Blessings - -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 |