HeroDiscussions.hs

#!/usr/bin/env runhaskell

{-# LANGUAGE OverloadedStrings #-}

module HeroDiscussion where

import Control.Applicative
import Control.Arrow
import Control.Monad.IO.Class
import Data.Attoparsec.Text as Parser
import Data.Char
import Data.Default
import Data.Either
import Data.Function
import Data.List
import Data.Monoid
import Data.Ord
import Data.Text (Text)
import Reddit
import Reddit.Types.Listing
import Reddit.Types.Options
import Reddit.Types.Subreddit
import System.Exit
import qualified Data.Text as Text
import qualified Data.Text.IO as Text
import qualified Reddit.Types.Post as Post
import qualified Reddit.Types.SearchOptions as Search

main = do
  res <- getIORes
  case res of
    Left err -> do
      print err
      exitFailure
    Right r -> do
      mapM_ Text.putStrLn $ filter (not . Text.isInfixOf "item" . Text.toLower) $ map formatRes r

getIORes = runRedditWithRateLimiting "intolerable" "nice try asshole" $ do
  Listing _ _ res <- getResults
  let ps = map (id &&& fmap snd . parseProbably fullTitle . Post.title) res
  liftIO $ mapM_ (print . Post.title . fst) $ filter (isLeft . snd) ps
  return $ sortBy (comparing (Post.created . fst)) $ pullSndRights [] ps
    where
      pullSndRights ys ((x, Right y):xs) = (x, y) : pullSndRights ys xs
      pullSndRights ys (_:xs) = pullSndRights ys xs
      pullSndRights ys [] = ys

formatRes :: (Post.Post, Date) -> Text
formatRes (p, _) =
  mconcat [ "["
          , Post.title p
          , "](http://reddit.com/r/dota2/"
          , unP $ Post.postID p
          , ")\n" ]
  where unP (Post.PostID x) = x

getResults = do
  l <- search (Just $ R "dota2") (Options Nothing (Just 100)) Search.Relevance "Hero Discussion"
  ls <- iterateM 200 l next
  return $ mconcat $ l : ls
  where
    next (Listing _ (Just a) _) =
      search (Just $ R "dota2") (Options (Just $ After a) (Just 100)) Search.Relevance "Hero Discussion"
    next (Listing _ Nothing _) = return $ Listing Nothing Nothing []

iterateM n _ _ | n <= 0 = return []
iterateM n a f = do
  r <- f a
  (:) r <$> iterateM (n - 1) r f

parseProbably :: Parser a -> Text -> Either Text a
parseProbably p t =
  case parseOnly p t of
    Left x -> Left t
    Right x -> Right x

fullTitle = do
  t <- Parser.takeWhile $ not . (== '(')
  d <- surround "(" (")" <|> "") date
  takeTill isEndOfLine
  endOfInput
  return (t, d)

surround b e p = b *> p <* e

date =
  Date <$> dayOfMonth <*> (monthName <* ss (ignore ",")) <*> ss decimal <|> do
    m <- monthName
    d <- dayOfMonth <* ss (ignore ",")
    y <- ss decimal
    return $ Date d m y

ignore :: Parser a -> Parser ()
ignore = option () . fmap (const ())

dayOfMonth = do
  d <- decimal
  ss $ ignore $ "st" <|> "nd" <|> "rd" <|> "th"
  return d

monthName = ss $ Parser.takeWhile isAlpha >>= fromText

data Date = Date { day :: Int
                 , month :: Int
                 , year :: Int }
  deriving (Show, Read, Eq)

instance Ord Date where
  compare = comparing year <> comparing month <> comparing day

ss p = p <* skipSpace

fromText m = case Text.toLower m of
  "january" -> return 1
  "february" -> return 2
  "march" -> return 3
  "april" -> return 4
  "may" -> return 5
  "june" -> return 6
  "july" -> return 7
  "august" -> return 8
  "september" -> return 9
  "october" -> return 10
  "november" -> return 11
  "december" -> return 12
  _ -> fail "invalid month name"