diff options
Diffstat (limited to 'src/Blessings.hs')
| -rw-r--r-- | src/Blessings.hs | 153 |
1 files changed, 143 insertions, 10 deletions
diff --git a/src/Blessings.hs b/src/Blessings.hs index 559db3e..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) @@ -264,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 @@ -281,15 +391,12 @@ instance Blessable a => Blessable (Blessings a) where n2 = n - n1 t1' = Bless.drop n1 t1 t2' = Bless.drop n2 t2 - isEmpty = (==0) . Bless.length . Bless.take 1 in - if n1 /= n || isEmpty t1' - then t2' - else Append t1' t2' + 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 @@ -303,15 +410,41 @@ instance Blessable a => Blessable (Blessings a) where 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 |