blessings: 2 -> 3

1 files changed, 37 insertions, 0 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 ""