summaryrefslogtreecommitdiffstats
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Blessings.hs362
-rw-r--r--src/Blessings/Internal.hs12
-rw-r--r--src/Blessings/Seq2.hs78
-rw-r--r--src/Blessings/String.hs18
-rw-r--r--src/Blessings/Text.hs18
5 files changed, 392 insertions, 96 deletions
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
generated by cgit v1.2.3 (git 2.25.1) at 2026-04-01 08:45:17 +0000