3 files changed, 62 insertions(+), 5 deletions(-)

M Adhoc.hs
M cheogram.cabal
M guix.scm

@@ 4,7 4,7 @@ import Prelude ()
 import BasicPrelude hiding (log)
 import Control.Concurrent (myThreadId, killThread)
 import Control.Concurrent.STM
-import Control.Error (hush, ExceptT, runExceptT, throwE, justZ)
+import Control.Error (hush, ExceptT, runExceptT, throwE, justZ, headZ)
 import Data.XML.Types as XML (Element(..), Node(NodeContent, NodeElement), Content(ContentText), isNamed, elementText, elementChildren, attributeText)
 import qualified Data.XML.Types as XML
 


@@ 17,6 17,7 @@ import qualified Data.Attoparsec.Text as Atto
 import qualified Data.Bool.HT as HT
 import qualified Data.Set as Set
 import qualified Data.Text as T
+import qualified Data.Text.ICU as ICU
 import qualified Data.UUID as UUID ( toString, toText )
 import qualified Data.UUID.V1 as UUID ( nextUUID )
 import qualified UnexceptionalIO.Trans ()


@@ 45,12 46,25 @@ mapNode name
 	| name == s"jabber:iq:register" = s"register"
 	| otherwise = name
 
+isEmojiRegex :: ICU.Regex
+isEmojiRegex = ICU.regex [] (s"(\\p{Emoji}.*\\p{Me})|\\p{Emoji_Presentation}|\65039")
+
+oneBotHelp :: Element -> Text
+oneBotHelp item
+	| Just _ <- ICU.find isEmojiRegex nameFirstGrapheme =
+		nameFirstGrapheme ++ s" " ++ command ++ s": " ++ T.stripStart (T.drop (T.length nameFirstGrapheme) name)
+	| otherwise = command ++ s": " ++ name
+	where
+	command = maybe mempty mapNode (attributeText (s"node") item)
+	nameFirstGrapheme = fromMaybe mempty $ fmap ICU.brkBreak $ headZ $
+		ICU.breaks (ICU.breakCharacter ICU.Root) name
+	name = fromMaybe mempty (attributeText (s"name") item)
+
 botHelp :: Maybe Text -> IQ -> Maybe Message
 botHelp header (IQ { iqTo = Just to, iqFrom = Just from, iqPayload = Just payload }) =
-	Just $ mkSMS from to $ maybe mempty (++ s"\n") header ++ (s"Help:\n\t") ++ intercalate (s"\n\t") (map (\item ->
-		maybe mempty mapNode (attributeText (s"node") item) ++ s": " ++
-		fromMaybe mempty (attributeText (s"name") item)
-	) items)
+	Just $ mkSMS from to $
+		maybe mempty (++ s"\n") header ++ (s"Help:\n\t") ++
+		intercalate (s"\n\t") (map oneBotHelp items)
 	where
 	items = isNamed (s"{http://jabber.org/protocol/disco#items}item") =<< elementChildren payload
 botHelp _ _ = Nothing

@@ 63,6 63,7 @@ executable cheogram
                 stm >= 2.4,
                 stm-delay,
                 text,
+                text-icu,
                 time,
                 uuid,
                 unexceptionalio,

@@ 19,10 19,51 @@
   (gnu packages haskell-crypto)
   (gnu packages haskell-web)
   (gnu packages haskell-xyz)
+  (gnu packages icu4c)
+  (gnu packages pkg-config)
   (ice-9 rdelim)
   (ice-9 popen)
 )
 
+(define-public ghc-text-icu
+  (package
+    (name "ghc-text-icu")
+    (version "0.8.0.2")
+    (source (origin
+              (method url-fetch)
+              (uri (hackage-uri "text-icu" version))
+              (sha256
+               (base32
+                "0frxrsj580ipgb3pdvw1msdz8d63j02vvrqhzjja3ixlq24am69d"))))
+    (build-system haskell-build-system)
+    (native-inputs (list ghc-hunit
+                         ghc-quickcheck
+                         ghc-random
+                         ghc-test-framework
+                         ghc-test-framework-hunit
+                         ghc-test-framework-quickcheck2
+                         pkg-config
+                         icu4c))
+    (home-page "https://github.com/haskell/text-icu")
+    (synopsis "Bindings to the ICU library")
+    (description
+     "Haskell bindings to the International Components for Unicode (ICU) libraries.
+These libraries provide robust and full-featured Unicode services on a wide
+variety of platforms. .  Features include: . * Both pure and impure bindings, to
+allow for fine control over efficiency and ease of use. . * Breaking of strings
+on character, word, sentence, and line boundaries. . * Access to the Unicode
+Character Database (UCD) of character metadata. . * String collation functions,
+for locales where the conventions for lexicographic ordering differ from the
+simple numeric ordering of character codes. . * Character set conversion
+functions, allowing conversion between Unicode and over 220 character encodings.
+. * Unicode normalization. (When implementations keep strings in a normalized
+form, they can be assured that equivalent strings have a unique binary
+representation.) . * Regular expression search and replace. . * Security checks
+for visually confusable (spoofable) strings. . * Bidirectional Unicode algorithm
+. * Calendar objects holding dates and times. . * Number and calendar
+formatting.")
+    (license license:bsd-3)))
+
 (define-public ghc-juicypixels-blurhash
   (package
     (name "ghc-juicypixels-blurhash")


@@ 741,6 782,7 @@ both a library and a command-line tool to access the library.")
         ghc-safe
         ghc-sha
         ghc-stm-delay
+        ghc-text-icu
         ghc-unexceptionalio-trans
         ghc-utility-ht
         ghc-uuid