From d253cbaa8253e8ad6c994740568d041fa022a375 Mon Sep 17 00:00:00 2001 From: Mats Rauhala Date: Mon, 16 May 2022 22:49:54 +0300 Subject: [PATCH] Can parse the tags --- reddit_tags/default.nix | 9 +++++---- reddit_tags/reddit-tags.cabal | 6 ++++++ reddit_tags/src/MyLib.hs | 20 +++++++++++++++++++- reddit_tags/src/Tags.hs | 18 ++++++++++++++++++ reddit_tags/src/Transformer.hs | 18 ++++++++++++++++++ reddit_tags/test/MyLibTest.hs | 15 ++++++++++++++- 6 files changed, 80 insertions(+), 6 deletions(-) create mode 100644 reddit_tags/src/Tags.hs create mode 100644 reddit_tags/src/Transformer.hs diff --git a/reddit_tags/default.nix b/reddit_tags/default.nix index 7e0a088..9109d3e 100644 --- a/reddit_tags/default.nix +++ b/reddit_tags/default.nix @@ -1,5 +1,5 @@ -{ mkDerivation, aeson, amqp, base, lens, lens-aeson, lib, mtl -, reddit-lib, text +{ mkDerivation, aeson, amqp, attoparsec, base, hspec, lens +, 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; } diff --git a/reddit_tags/reddit-tags.cabal b/reddit_tags/reddit-tags.cabal index 6998365..a6c2ba6 100644 --- a/reddit_tags/reddit-tags.cabal +++ b/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 diff --git a/reddit_tags/src/MyLib.hs b/reddit_tags/src/MyLib.hs index a4d3dda..4d05047 100644 --- a/reddit_tags/src/MyLib.hs +++ b/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 diff --git a/reddit_tags/src/Tags.hs b/reddit_tags/src/Tags.hs new file mode 100644 index 0000000..1a46886 --- /dev/null +++ b/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 diff --git a/reddit_tags/src/Transformer.hs b/reddit_tags/src/Transformer.hs new file mode 100644 index 0000000..22986be --- /dev/null +++ b/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 diff --git a/reddit_tags/test/MyLibTest.hs b/reddit_tags/test/MyLibTest.hs index 3e2059e..62bd7d4 100644 --- a/reddit_tags/test/MyLibTest.hs +++ b/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"]