blessings: 2 -> 3

2 files changed, 37 insertions, 40 deletions

diff --git a/src/Blessings/Extra.hs b/src/Blessings/Extra.hs
new file mode 100644
index 0000000..caa8e2d
--- /dev/null
+++ b/src/Blessings/Extra.hs
@@ -0,0 +1,37 @@
+module Blessings.Extra where
+
+import Blessings
+import Data.Char (isPrint,showLitChar)
+import Data.MonoTraversable (Element, oall, ofoldMap)
+import Data.Sequences (singleton)
+import Data.String (fromString)
+
+quoteSpecials :: (Blessable a, Element a ~ Char) => Blessings a -> Blessings a
+quoteSpecials = cataBlessings quoteSpecialsPlain SGR Append
+
+quoteSpecialsPlain :: (Blessable a, Element a ~ Char) => a -> Blessings a
+quoteSpecialsPlain =
+    quoteSpecialsPlain' id (SGR [35])
+
+quoteSpecialsPlain'
+    :: forall a. (Blessable a, Element a ~ Char)
+    => (Blessings a -> Blessings a)
+    -> (Blessings a -> Blessings a)
+    -> a
+    -> Blessings a
+quoteSpecialsPlain' printable unprintable s =
+    if oall isPrint s
+      then printable (Plain s)
+      else normalize (ofoldMap quoteSpecialChar s)
+  where
+
+    quoteSpecialChar :: (Blessable a, Element a ~ Char) => Char -> Blessings a
+    quoteSpecialChar c =
+        if isPrint c
+          then printable (Plain (singleton c))
+          else unprintable (Plain (fromString (showLitChar' c)))
+
+    showLitChar' :: Char -> String
+    showLitChar' = \case
+        '\ESC' -> "^["
+        c -> showLitChar c ""
diff --git a/src/Blessings/String/Extra.hs b/src/Blessings/String/Extra.hs
deleted file mode 100644
index 74c4ef0..0000000
--- a/src/Blessings/String/Extra.hs
+++ /dev/null
@@ -1,40 +0,0 @@
-module Blessings.String.Extra where
-
-import Blessings
-import Control.Arrow ((&&&))
-import Data.Char (isPrint,showLitChar)
-import Data.Function (on)
-import Data.List (groupBy)
-
-
-quoteSpecials :: Blessings String -> Blessings String
-quoteSpecials = \case
-  Plain s -> quoteSpecials' s
-  SGR pm x -> SGR pm (quoteSpecials x)
-  Append a b -> Append (quoteSpecials a) (quoteSpecials b)
-  Empty -> Empty
-
-
-quoteSpecials' :: String -> Blessings String
-quoteSpecials' s =
-    mconcat . map (uncurry renderClassifiedString) $ classifiedGroupBy isPrint s
-  where
-    renderClassifiedString :: Bool -> String -> Blessings String
-    renderClassifiedString = \case
-        True -> printableColor . Plain
-        False -> unprintableColor . Plain . showLitChar'
-
-    (printableColor, unprintableColor) =
-        (id, SGR [35])
-        --if hasFocus
-          --then (color focus colorConfig, color unprintableFocus colorConfig)
-          --else (color quote colorConfig, color unprintableNormal colorConfig)
-
-    showLitChar' :: String -> String
-    showLitChar' = (>>= f)
-      where f '\ESC' = "^["
-            f c = showLitChar c ""
-
-    classifiedGroupBy :: Eq b => (a -> b) -> [a] -> [(b, [a])]
-    classifiedGroupBy f =
-        map (f . head &&& id) . groupBy ((==) `on` f)