Can parse the tags

reddit_tags/default.nix

@@ -1,5 +1,5 @@
-{ mkDerivation, aeson, amqp, base, lens, lens-aeson, lib, mtl
+{ mkDerivation, aeson, amqp, attoparsec, base, hspec, lens
-, reddit-lib, text
+, lens-aeson, lib, mtl, reddit-lib, text, transformers
 }:
 mkDerivation {
   pname = "reddit-tags";
@@ -8,10 +8,11 @@ mkDerivation {
   isLibrary = true;
   isExecutable = true;
   libraryHaskellDepends = [
-    aeson amqp base lens lens-aeson mtl reddit-lib text
+    aeson amqp attoparsec base lens lens-aeson mtl reddit-lib text
+    transformers
   ];
   executableHaskellDepends = [ base ];
-  testHaskellDepends = [ base ];
+  testHaskellDepends = [ base hspec ];
   license = "unknown";
   hydraPlatforms = lib.platforms.none;
 }

reddit_tags/reddit-tags.cabal

@@ -20,6 +20,8 @@ extra-source-files: CHANGELOG.md
 
 library
     exposed-modules:  MyLib
+                      Tags
+                      Transformer
 
     -- Modules included in this library but not exported.
     -- other-modules:
@@ -35,6 +37,8 @@ library
                     , lens
                     , lens-aeson
                     , transformers
+                    , attoparsec
+                    , bytestring
     hs-source-dirs:   src
     default-language: Haskell2010
 
@@ -59,3 +63,5 @@ test-suite reddit-tags-test
     hs-source-dirs:   test
     main-is:          MyLibTest.hs
     build-depends:    base ^>=4.15.1.0
+                    , hspec
+                    , reddit-tags

reddit_tags/src/MyLib.hs

@@ -10,6 +10,14 @@ import Control.Exception (bracket)
 import Control.Concurrent (newEmptyMVar, readMVar)
 import Control.Monad (void)
 
+import Control.Lens
+import Data.Aeson.Lens
+import Transformer
+import Data.ByteString.Lazy (ByteString)
+import Control.Category ((>>>))
+import Control.Arrow (arr, (&&&))
+import Tags (parseTags)
+
 data AMQP = AMQP
   { host :: String
   , vhost :: Text
@@ -24,6 +32,12 @@ getAMQP = runMaybeT $
     lookupEnvM = MaybeT . lookupEnv
     lookupEnvMText = fmap T.pack . lookupEnvM
 
+tagTransformer :: Transformer IO ByteString ()
+tagTransformer =
+  arrOpt (preview (key "content" . key "title" . _String))
+  >>> arr id &&& arr parseTags
+  >>> liftTransformer print
+
 someFunc :: IO ()
 someFunc = do
   Just AMQP{..} <- getAMQP
@@ -34,6 +48,10 @@ someFunc = do
     declareQueue chan newQueue {queueName="reddit_tags"}
     bindQueue chan "reddit_tags" "reddit_posts" "key"
     consumeMsgs chan "reddit_tags" Ack $ \(msg, env) -> do
-      print msg
+      void $ runTransformer tagTransformer (msgBody msg)
+      -- let body = msgBody msg
+      -- let title = body ^? key "content" . key "title"
+      -- print title
+      -- print $ parseTags title
       ackEnv env
     void getLine

reddit_tags/src/Tags.hs

@@ -0,0 +1,18 @@
+{-# LANGUAGE ApplicativeDo #-}
+module Tags (parseTags) where
+
+import qualified Data.Attoparsec.Text as A
+import Data.Attoparsec.Text (Parser)
+import Data.Text (Text)
+import Data.Either (fromRight)
+
+tag :: Parser Text
+tag = do
+  A.skipWhile (/= '[')
+  A.char '[' *> A.takeWhile (/= ']') <* A.char ']'
+
+tags :: Parser [Text]
+tags = A.many1 tag
+
+parseTags :: Text -> [Text]
+parseTags = fromRight [] . A.parseOnly tags

reddit_tags/src/Transformer.hs

@@ -0,0 +1,18 @@
+{-# LANGUAGE DerivingVia #-}
+module Transformer where
+
+import Control.Category ( Category )
+import Control.Arrow ( Arrow, ArrowChoice, Kleisli(Kleisli) )
+import Control.Monad.Trans.Maybe ( MaybeT(MaybeT) )
+
+newtype Transformer m a b = Transformer (a -> m (Maybe b))
+  deriving (Category, Arrow, ArrowChoice) via Kleisli (MaybeT m)
+
+arrOpt :: Applicative m => (a -> Maybe b) -> Transformer m a b
+arrOpt f = Transformer (pure . f)
+
+liftTransformer :: Monad m => (a -> m b) -> Transformer m a b
+liftTransformer f = Transformer (fmap Just . f)
+
+runTransformer :: Monad m => Transformer m a b -> a -> m (Maybe b)
+runTransformer (Transformer tr) = tr

reddit_tags/test/MyLibTest.hs

@@ -1,4 +1,17 @@
+{-# LANGUAGE OverloadedStrings #-}
 module Main (main) where
 
+import Tags (parseTags)
+import Test.Hspec
+
 main :: IO ()
-main = putStrLn "Test suite not yet implemented."
+main = hspec $
+  describe "Parser" $ do
+    it "Returns no results if there are no tags" $
+      parseTags "foo bar" `shouldBe` []
+    it "Returns a single result" $
+      parseTags "[foo]" `shouldBe` ["foo"]
+    it "Finds multiple results" $
+      parseTags "[foo][bar]" `shouldBe` ["foo", "bar"]
+    it "Finds multiple results with other text interleaved" $
+      parseTags "prefix [foo] infix [bar] suffix" `shouldBe` ["foo", "bar"]