add Seq2 Blessings Text split2HEADmaster

3 files changed, 95 insertions, 2 deletions

diff --git a/blessings.cabal b/blessings.cabal
index 4d6e0d7..696bbc2 100644
--- a/blessings.cabal
+++ b/blessings.cabal
@@ -10,14 +10,20 @@ source-repository head
     location: https://cgit.krebsco.de/blessings
 
 library
-    exposed-modules:  Blessings
+    exposed-modules:
+        Blessings
+        Blessings.Seq2
+
     hs-source-dirs:   src
     default-language: GHC2024
     ghc-options:      -Wall -Wextra
     build-depends:
         base,
+        dlist,
         extra,
-        mono-traversable
+        mono-traversable,
+        seq2,
+        text
 
 test-suite test-blessings
     type:             exitcode-stdio-1.0
diff --git a/src/Blessings.hs b/src/Blessings.hs
index 67eecad..e860b1d 100644
--- a/src/Blessings.hs
+++ b/src/Blessings.hs
@@ -35,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
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
+           )