diff options
| -rw-r--r-- | blessings.cabal | 13 | ||||
| -rw-r--r-- | src/Blessings.hs | 181 | ||||
| -rw-r--r-- | src/Blessings/ByteString.hs | 18 | ||||
| -rw-r--r-- | src/Blessings/ByteString/Lazy.hs | 18 | ||||
| -rw-r--r-- | src/Blessings/Internal.hs | 1 | ||||
| -rw-r--r-- | src/Blessings/String.hs | 1 | ||||
| -rw-r--r-- | src/Blessings/String/WCWidth.hs | 64 | ||||
| -rw-r--r-- | src/Blessings/Text.hs | 1 | ||||
| -rw-r--r-- | src/Blessings/Text/WCWidth.hs | 64 | ||||
| -rw-r--r-- | test/Spec.hs | 59 |
10 files changed, 397 insertions, 23 deletions
diff --git a/blessings.cabal b/blessings.cabal index 4b1570a..c5dc7d5 100644 --- a/blessings.cabal +++ b/blessings.cabal @@ -3,17 +3,24 @@ build-type: Simple cabal-version: >= 1.8 license: MIT name: blessings -version: 2.1.0 +version: 2.5.1 library build-depends: base, - text + bytestring, + extra, + text, + wcwidth exposed-modules: Blessings, + Blessings.ByteString, + Blessings.ByteString.Lazy, Blessings.Internal, Blessings.String, - Blessings.Text + Blessings.String.WCWidth + Blessings.Text, + Blessings.Text.WCWidth ghc-options: -O2 -Wall hs-source-dirs: src diff --git a/src/Blessings.hs b/src/Blessings.hs index 26a0666..b942565 100644 --- a/src/Blessings.hs +++ b/src/Blessings.hs @@ -13,6 +13,7 @@ import Control.Applicative import Data.Ix (inRange) import Data.List (genericDrop) import Data.String +import Data.Tuple.Extra (both, first, second) import Data.Word (Word8) import qualified Prelude import Prelude hiding (drop, length, take) @@ -47,13 +48,16 @@ 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 @@ -151,8 +155,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" @@ -261,11 +265,120 @@ stripSGR = \case 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 "" -instance Blessable a => Blessable (Blessings a) where +instance (Eq a, 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 @@ -273,33 +386,65 @@ instance Blessable a => Blessable (Blessings a) where 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 = Bless.length (Bless.take n t1) + n2 = n - n1 + t1' = Bless.drop n1 t1 + t2' = Bless.drop n2 t2 + in + normalizeHead $ Append t1' t2' Plain s -> - Plain (Bless.drop n s) + normalize $ Plain (Bless.drop n s) SGR pm t -> - SGR pm (Bless.drop n t) + normalize $ SGR pm (Bless.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' = Bless.take n t1 + n' = n - Bless.length t1' + in + if n' > 0 + then t1' <> Bless.take n' t2 + else t1' Plain s -> - Plain (Bless.take n s) + normalize $ Plain (Bless.take n s) SGR pm t -> - SGR pm (Bless.take n t) + normalize $ SGR pm (Bless.take n t) Empty -> Empty + splitAt n = \case + Append t1 t2 -> + both normalize $ + let + nt1 = Bless.length t1 + in + if n <= nt1 + then second (<>t2) $ Bless.splitAt n t1 + else first (t1<>) $ Bless.splitAt (n - nt1) t2 + Plain s -> + both (normalize . Plain) $ Bless.splitAt n s + SGR pm t -> + both (normalize . SGR pm) $ Bless.splitAt n t + Empty -> + (Empty, Empty) + intercalate i = \case [] -> mempty [t] -> t - (t:ts) -> t <> i <> Bless.intercalate i ts + (t:ts) -> normalize $ t <> i <> Bless.intercalate i ts fromWord8 = Plain . Bless.fromWord8 + + +chunksOf :: (Eq a, Blessable a) => Int -> a -> [a] +chunksOf k = rec + where + rec t = + case Bless.splitAt k t of + (tl, tr) + | tl == mempty -> [] + | otherwise -> tl : rec tr diff --git a/src/Blessings/ByteString.hs b/src/Blessings/ByteString.hs new file mode 100644 index 0000000..42139fa --- /dev/null +++ b/src/Blessings/ByteString.hs @@ -0,0 +1,18 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Blessings.ByteString + ( module Blessings + ) where + +import Blessings +import Blessings.Internal +import qualified Data.ByteString.Char8 as B + + +instance Blessable B.ByteString where + length = B.length + drop = B.drop + take = B.take + splitAt = B.splitAt + intercalate = B.intercalate + fromWord8 = B.pack . show diff --git a/src/Blessings/ByteString/Lazy.hs b/src/Blessings/ByteString/Lazy.hs new file mode 100644 index 0000000..c0f521c --- /dev/null +++ b/src/Blessings/ByteString/Lazy.hs @@ -0,0 +1,18 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Blessings.ByteString.Lazy + ( module Blessings + ) where + +import Blessings +import Blessings.Internal +import qualified Data.ByteString.Lazy.Char8 as L + + +instance Blessable L.ByteString where + length = fromIntegral . L.length + drop = L.drop . fromIntegral + take = L.take . fromIntegral + splitAt = L.splitAt . fromIntegral + intercalate = L.intercalate + fromWord8 = L.pack . show diff --git a/src/Blessings/Internal.hs b/src/Blessings/Internal.hs index 0ed5556..38c9069 100644 --- a/src/Blessings/Internal.hs +++ b/src/Blessings/Internal.hs @@ -8,5 +8,6 @@ class (IsString a, Monoid a) => Blessable a where length :: a -> Int drop :: Int -> a -> a take :: Int -> a -> a + splitAt :: Int -> a -> (a, a) intercalate :: a -> [a] -> a fromWord8 :: Word8 -> a diff --git a/src/Blessings/String.hs b/src/Blessings/String.hs index 005cd7b..bc3d8cc 100644 --- a/src/Blessings/String.hs +++ b/src/Blessings/String.hs @@ -14,5 +14,6 @@ instance Blessable String where length = L.length drop = L.drop take = L.take + splitAt = L.splitAt intercalate = L.intercalate fromWord8 = show diff --git a/src/Blessings/String/WCWidth.hs b/src/Blessings/String/WCWidth.hs new file mode 100644 index 0000000..2160f99 --- /dev/null +++ b/src/Blessings/String/WCWidth.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE PatternGuards #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Blessings.String.WCWidth + ( module Blessings + ) where + +import Blessings +import Blessings.Internal +import Data.Char.WCWidth qualified as WCWidth +import Data.List qualified as List + + +instance Blessable String where + length = length' + drop = drop' + take = take' + splitAt = splitAt' + intercalate = List.intercalate + fromWord8 = show + + +length' :: String -> Int +length' = foldr ((+) . wcwidth') 0 + +drop' :: Int -> String -> String +drop' k t = + if k <= 0 + then t + else + case t of + c : t' -> + drop' (k - wcwidth' c) t' + [] -> mempty + +take' :: Int -> String -> String +take' k0 = + rec k0 + where + rec k t = + if | (c : t') <- t, nc <- wcwidth' c, nc <= k -> + c : rec (k - nc) t' + + | otherwise -> + [] + +splitAt' :: Int -> String -> (String, String) +splitAt' k0 = + rec k0 [] + where + rec k a t = + if | (c : t') <- t, nc <- wcwidth' c, nc <= k -> + rec (k - nc) (c : a) t' + + | otherwise -> + (reverse a, t) + +-- TODO this breaks when WCWidth.wcwidth returns -1, which happens for +-- non-printable characters like '\n'. +-- Following wcwidth' isn't entirely correct because WCWidth.wcwidth '\0' == 0 +wcwidth' :: Char -> Int +wcwidth' = max 1 . WCWidth.wcwidth diff --git a/src/Blessings/Text.hs b/src/Blessings/Text.hs index 1f82c22..236b5d0 100644 --- a/src/Blessings/Text.hs +++ b/src/Blessings/Text.hs @@ -14,5 +14,6 @@ instance Blessable Text where length = T.length drop = T.drop take = T.take + splitAt = T.splitAt intercalate = T.intercalate fromWord8 = T.pack . show diff --git a/src/Blessings/Text/WCWidth.hs b/src/Blessings/Text/WCWidth.hs new file mode 100644 index 0000000..277e1a1 --- /dev/null +++ b/src/Blessings/Text/WCWidth.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE PatternGuards #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Blessings.Text.WCWidth + ( module Blessings + ) where + +import Blessings +import Blessings.Internal +import Data.Char.WCWidth qualified as WCWidth +import Data.Text (Text) +import Data.Text qualified as Text + + +instance Blessable Text where + length = length' + drop = drop' + take = take' + splitAt = splitAt' + intercalate = Text.intercalate + fromWord8 = Text.pack . show + + +length' :: Text -> Int +length' = Text.foldr ((+) . wcwidth') 0 + +drop' :: Int -> Text -> Text +drop' k t = + if k <= 0 + then t + else + case Text.uncons t of + Just (c, t') -> + drop' (k - wcwidth' c) t' + Nothing -> mempty + +take' :: Int -> Text -> Text +take' k0 = + Text.pack . rec k0 + where + rec k t = + if | Just (c, t') <- Text.uncons t, nc <- wcwidth' c, nc <= k -> + c : rec (k - nc) t' + + | otherwise -> + [] + +splitAt' :: Int -> Text -> (Text, Text) +splitAt' k0 = + rec k0 mempty + where + rec k a t = + if | Just (c, t') <- Text.uncons t, nc <- wcwidth' c, nc <= k -> + rec (k - nc) (c : a) t' + + | otherwise -> + (Text.pack $ reverse a, t) + +-- TODO this breaks when WCWidth.wcwidth returns -1, which happens for +-- non-printable characters like '\n'. +-- Following wcwidth' isn't entirely correct because WCWidth.wcwidth '\0' == 0 +wcwidth' :: Char -> Int +wcwidth' = max 1 . WCWidth.wcwidth diff --git a/test/Spec.hs b/test/Spec.hs index 298eb04..24a17e2 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,7 +1,19 @@ +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE ScopedTypeVariables #-} -import Test.QuickCheck +{-# OPTIONS_GHC -fno-warn-orphans #-} +import Blessings.Internal as B +import Blessings.String +import Control.Exception +import System.IO.Unsafe +import System.Timeout import Test.Hspec -import Blessings +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 = @@ -23,3 +35,46 @@ main = 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 (B.take 1 x <> B.drop 1 x) == normalize x + + it "uncurry (<>) (splitAt i x) == x" $ + property $ \(i :: Int, x :: Blessings String) -> + unsafeTimeout 100000 $ + normalize (uncurry (<>) (B.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) = B.splitAt i x + n = B.length x + in + if | i <= 0 -> B.length l == 0 && B.length r == n + | i <= n -> B.length l == i && B.length r == n - i + | otherwise -> B.length l == n && B.length 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 + B.length (B.take i infx) == i + + it "can drop from infinite structure" $ + property $ \(n :: NonNegative Int) -> + unsafeTimeout 100000 $ + let i = getNonNegative n in + B.length (B.take i (B.drop i infx)) == i + + it "can take concat of infinite structures" $ + property $ \(x :: Blessings String) -> + unsafeTimeout 100000 $ + B.length (B.take 1 $ infx <> x) <= 1 |