use mono-traversable

8 files changed, 96 insertions, 277 deletions

diff --git a/src/Blessings.hs b/src/Blessings.hs
index a62546e..3ee32a2 100644
--- a/src/Blessings.hs
+++ b/src/Blessings.hs
@@ -1,21 +1,29 @@
 {-# 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)
 
 
+type Blessable t =
+  ( Eq t
+  , IsString t
+  , Monoid t
+  , IsSequence t
+  , Index t ~ Int
+  )
+
 type Ps = Word8
 type Pm = [Ps]
 
@@ -62,6 +70,58 @@ 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
@@ -216,7 +276,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
 
@@ -249,10 +309,10 @@ 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
@@ -372,46 +432,43 @@ normalizePm pm0 =
         [] -> xs
 
 
-pp :: (Blessable a) => Blessings a -> a
-pp t = render emptyRenderState t ""
+pp :: Blessable a => Blessings a -> a
+pp t = render emptyRenderState t mempty
 
 
-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
-  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 ->
           let
-            n1 = Bless.length (Bless.take n t1)
+            n1 = S.lengthIndex (S.take n t1)
             n2 = n - n1
-            t1' = Bless.drop n1 t1
-            t2' = Bless.drop n2 t2
+            t1' = S.drop n1 t1
+            t2' = S.drop n2 t2
           in
             normalizeHead $ Append t1' t2'
       Plain s ->
-          normalizeHead $ Plain (Bless.drop n s)
+          normalizeHead $ Plain (S.drop n s)
       SGR pm t ->
-          normalizeHead $ SGR pm (Bless.drop n t)
+          normalizeHead $ SGR pm (S.drop n t)
       Empty ->
           Empty
 
   take n = \case
       Append t1 t2 ->
           let
-            t1' = Bless.take n t1
-            n' = n - Bless.length t1'
+            t1' = S.take n t1
+            n' = n - S.lengthIndex t1'
           in
             normalizeHead $
               if n' > 0
-                then t1' <> Bless.take n' t2
+                then t1' <> S.take n' t2
                 else t1'
       Plain s ->
-          normalizeHead $ Plain (Bless.take n s)
+          normalizeHead $ Plain (S.take n s)
       SGR pm t ->
-          normalizeHead $ SGR pm (Bless.take n t)
+          normalizeHead $ SGR pm (S.take n t)
       Empty ->
           Empty
 
@@ -419,47 +476,39 @@ instance (Eq a, Blessable a) => Blessable (Blessings a) where
       Append t1 t2 ->
         both normalizeHead $
           let
-            nt1 = Bless.length t1
+            nt1 = S.lengthIndex t1
           in
             if n <= nt1
-              then second (<>t2) $ Bless.splitAt n t1
-              else first (t1<>) $ Bless.splitAt (n - nt1) t2
+              then second (<>t2) $ S.splitAt n t1
+              else first (t1<>) $ S.splitAt (n - nt1) t2
       Plain s ->
-        both (normalizeHead . Plain) $ Bless.splitAt n s
+        both (normalizeHead . Plain) $ S.splitAt n s
       SGR pm t ->
-        both (normalizeHead . SGR pm) $ Bless.splitAt n t
+        both (normalizeHead . SGR pm) $ S.splitAt n t
       Empty ->
         (Empty, Empty)
 
   break p = \case
       Append t1 t2 ->
         both normalizeHead $
-          case Bless.break p t1 of
+          case S.break p t1 of
             (t1l, t1r)
-              | t1r == mempty -> first (t1l<>) $ Bless.break p t2
+              | t1r == mempty -> first (t1l<>) $ S.break p t2
               | otherwise -> (t1l, t1r <> t2)
-      Plain s ->
-        both (normalizeHead . Plain) $ Bless.break p s
+      Plain s
+        | p s       -> (Empty, Plain s)
+        | otherwise -> (Plain s, Empty)
       SGR pm t ->
-        both (normalizeHead . SGR pm) $ Bless.break p t
+        both (normalizeHead . SGR pm) $ S.break p t
       Empty ->
         (Empty, Empty)
 
-  intercalate i = \case
-      [] -> mempty
-      [t] -> t
-      (t:ts) -> normalize $ t <> i <> Bless.intercalate i ts
-
-  fromWord8 = Plain . Bless.fromWord8
-
-  show = Plain . Bless.show
-
 
-chunksOf :: (Eq a, Blessable a) => Int -> a -> [a]
+chunksOf :: Blessable a => Int -> a -> [a]
 chunksOf k = rec
   where
     rec t =
-        case Bless.splitAt k t of
+        case S.splitAt k t of
           (tl, tr)
             | tl == mempty -> []
             | otherwise -> tl : rec tr
diff --git a/src/Blessings/ByteString.hs b/src/Blessings/ByteString.hs
deleted file mode 100644
index 4fe66cc..0000000
--- a/src/Blessings/ByteString.hs
+++ /dev/null
@@ -1,20 +0,0 @@
-{-# 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
-  break = B.break
-  intercalate = B.intercalate
-  fromWord8 = B.pack . Prelude.show
-  show = B.pack . Prelude.show
diff --git a/src/Blessings/ByteString/Lazy.hs b/src/Blessings/ByteString/Lazy.hs
deleted file mode 100644
index 23394b5..0000000
--- a/src/Blessings/ByteString/Lazy.hs
+++ /dev/null
@@ -1,20 +0,0 @@
-{-# 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
-  break = L.break
-  intercalate = L.intercalate
-  fromWord8 = L.pack . Prelude.show
-  show = L.pack . Prelude.show
diff --git a/src/Blessings/Internal.hs b/src/Blessings/Internal.hs
deleted file mode 100644
index 62d8fd4..0000000
--- a/src/Blessings/Internal.hs
+++ /dev/null
@@ -1,16 +0,0 @@
-{-# LANGUAGE ConstrainedClassMethods #-}
-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
-  splitAt :: Int -> a -> (a, a)
-  break :: (Char -> Bool) -> a -> (a, a)
-  intercalate :: a -> [a] -> a
-  fromWord8 :: Word8 -> a
-  show :: Show x => x -> a
diff --git a/src/Blessings/String.hs b/src/Blessings/String.hs
deleted file mode 100644
index 8dc6bcf..0000000
--- a/src/Blessings/String.hs
+++ /dev/null
@@ -1,21 +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
-  splitAt = L.splitAt
-  break = L.break
-  intercalate = L.intercalate
-  fromWord8 = Prelude.show
-  show = Prelude.show
diff --git a/src/Blessings/String/WCWidth.hs b/src/Blessings/String/WCWidth.hs
deleted file mode 100644
index 16ab853..0000000
--- a/src/Blessings/String/WCWidth.hs
+++ /dev/null
@@ -1,66 +0,0 @@
-{-# 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'
-  break       = List.break
-  intercalate = List.intercalate
-  fromWord8   = Prelude.show
-  show        = Prelude.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
deleted file mode 100644
index 04572dd..0000000
--- a/src/Blessings/Text.hs
+++ /dev/null
@@ -1,21 +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
-  splitAt = T.splitAt
-  break = T.break
-  intercalate = T.intercalate
-  fromWord8 = T.pack . Prelude.show
-  show = T.pack . Prelude.show
diff --git a/src/Blessings/Text/WCWidth.hs b/src/Blessings/Text/WCWidth.hs
deleted file mode 100644
index 84e7cfa..0000000
--- a/src/Blessings/Text/WCWidth.hs
+++ /dev/null
@@ -1,66 +0,0 @@
-{-# 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'
-  break       = Text.break
-  intercalate = Text.intercalate
-  fromWord8   = Text.pack . Prelude.show
-  show        = Text.pack . Prelude.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