-- |
-- Module: Web.WikiCFP.Scraper.Scalpel
-- Description: Scraper implementation with Scalpel
-- Maintainer: Toshio Ito <debug.ito@gmail.com>
--
-- 
{-# LANGUAGE CPP, OverloadedStrings #-}

module Web.WikiCFP.Scraper.Scalpel
       ( ErrorMsg,
         Scraper',
         confRoot,
         searchRoot
       ) where

import Control.Applicative ((<$>), (<*>), (<|>), (<*), (*>), optional, pure)
import Control.Monad (guard, forM_, mzero)
import Data.List (sort)
import Data.Maybe (catMaybes)
import Data.Monoid ((<>))
import Data.Text (Text, pack)
import Data.Time (Day, fromGregorian)
import Data.Attoparsec.Text (Parser, parseOnly, skipSpace, string, endOfInput, decimal, takeText, char)
import Text.HTML.Scalpel.Core
  ( Scraper,
    (@:), (@=), (//), chroot, chroots, text, texts, attr, hasClass
  )

import Web.WikiCFP.Scraper.Type (Event(..), When(..))

type ErrorMsg = String

type Scraper' = Scraper Text

-- | Root scraper for conference Events.
confRoot :: Scraper' (Either ErrorMsg [Event])
confRoot :: Scraper' (Either ErrorMsg [Event])
confRoot = ScraperT Text Identity [Either ErrorMsg [Event]]
-> Scraper' (Either ErrorMsg [Event])
forall (m :: * -> *) e a.
(Functor m, Monad m) =>
m [Either e [a]] -> m (Either e [a])
concatSuccess (ScraperT Text Identity [Either ErrorMsg [Event]]
 -> Scraper' (Either ErrorMsg [Event]))
-> ScraperT Text Identity [Either ErrorMsg [Event]]
-> Scraper' (Either ErrorMsg [Event])
forall a b. (a -> b) -> a -> b
$ Selector
-> Scraper' (Either ErrorMsg [Event])
-> ScraperT Text Identity [Either ErrorMsg [Event]]
forall str (m :: * -> *) a.
(StringLike str, Monad m) =>
Selector -> ScraperT str m a -> ScraperT str m [a]
chroots (TagName
"div" TagName -> [AttributePredicate] -> Selector
@: [ErrorMsg -> AttributePredicate
hasClass ErrorMsg
"contsec"] Selector -> Selector -> Selector
// Selector
"table") (Scraper' (Either ErrorMsg [Event])
 -> ScraperT Text Identity [Either ErrorMsg [Event]])
-> Scraper' (Either ErrorMsg [Event])
-> ScraperT Text Identity [Either ErrorMsg [Event]]
forall a b. (a -> b) -> a -> b
$ Scraper' (Either ErrorMsg [Event])
eventsTable

-- | Root scraper for searched Events.
searchRoot :: Scraper' (Either ErrorMsg [Event])
searchRoot :: Scraper' (Either ErrorMsg [Event])
searchRoot = Scraper' (Either ErrorMsg [Event])
confRoot

concatSuccess :: (Functor m, Monad m) => m [Either e [a]] -> m (Either e [a])
concatSuccess :: m [Either e [a]] -> m (Either e [a])
concatSuccess = ([Either e [a]] -> Either e [a])
-> m [Either e [a]] -> m (Either e [a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([Either e [a]] -> Either e [a])
 -> m [Either e [a]] -> m (Either e [a]))
-> ([Either e [a]] -> Either e [a])
-> m [Either e [a]]
-> m (Either e [a])
forall a b. (a -> b) -> a -> b
$ ([[a]] -> [a]) -> Either e [[a]] -> Either e [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[a]] -> [a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Either e [[a]] -> Either e [a])
-> ([Either e [a]] -> Either e [[a]])
-> [Either e [a]]
-> Either e [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Either e [a]] -> Either e [[a]]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence

-- | Scrape events from a table. Use with the root at @\<table\>@ tag.
eventsTable :: Scraper' (Either ErrorMsg [Event])
eventsTable :: Scraper' (Either ErrorMsg [Event])
eventsTable = do
  [EventRow]
rows <- Selector
-> ScraperT Text Identity EventRow
-> ScraperT Text Identity [EventRow]
forall str (m :: * -> *) a.
(StringLike str, Monad m) =>
Selector -> ScraperT str m a -> ScraperT str m [a]
chroots Selector
"tr" (ScraperT Text Identity EventRow
eventRow1 ScraperT Text Identity EventRow
-> ScraperT Text Identity EventRow
-> ScraperT Text Identity EventRow
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ScraperT Text Identity EventRow
eventRow2 ScraperT Text Identity EventRow
-> ScraperT Text Identity EventRow
-> ScraperT Text Identity EventRow
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ScraperT Text Identity EventRow
eventRowHeader)
  case [EventRow]
rows of
    (EventRow
EventRowHeader : [EventRow]
rest) -> Either ErrorMsg [Event] -> Scraper' (Either ErrorMsg [Event])
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ErrorMsg [Event] -> Scraper' (Either ErrorMsg [Event]))
-> Either ErrorMsg [Event] -> Scraper' (Either ErrorMsg [Event])
forall a b. (a -> b) -> a -> b
$ [EventRow] -> Either ErrorMsg [Event]
rowsToEvents_noHeader [EventRow]
rest
    [EventRow]
_ -> Scraper' (Either ErrorMsg [Event])
forall (m :: * -> *) a. MonadPlus m => m a
mzero
    

-- | Intermediate result of parsing under events \<table\>.
data EventRow = EventRowHeader
              | EventRow1 Text Text Text -- ^ shortName, URL and longName
              | EventRow2 Text Text Text -- ^ when, where, deadlines
              deriving (EventRow -> EventRow -> Bool
(EventRow -> EventRow -> Bool)
-> (EventRow -> EventRow -> Bool) -> Eq EventRow
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EventRow -> EventRow -> Bool
$c/= :: EventRow -> EventRow -> Bool
== :: EventRow -> EventRow -> Bool
$c== :: EventRow -> EventRow -> Bool
Eq,Eq EventRow
Eq EventRow
-> (EventRow -> EventRow -> Ordering)
-> (EventRow -> EventRow -> Bool)
-> (EventRow -> EventRow -> Bool)
-> (EventRow -> EventRow -> Bool)
-> (EventRow -> EventRow -> Bool)
-> (EventRow -> EventRow -> EventRow)
-> (EventRow -> EventRow -> EventRow)
-> Ord EventRow
EventRow -> EventRow -> Bool
EventRow -> EventRow -> Ordering
EventRow -> EventRow -> EventRow
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: EventRow -> EventRow -> EventRow
$cmin :: EventRow -> EventRow -> EventRow
max :: EventRow -> EventRow -> EventRow
$cmax :: EventRow -> EventRow -> EventRow
>= :: EventRow -> EventRow -> Bool
$c>= :: EventRow -> EventRow -> Bool
> :: EventRow -> EventRow -> Bool
$c> :: EventRow -> EventRow -> Bool
<= :: EventRow -> EventRow -> Bool
$c<= :: EventRow -> EventRow -> Bool
< :: EventRow -> EventRow -> Bool
$c< :: EventRow -> EventRow -> Bool
compare :: EventRow -> EventRow -> Ordering
$ccompare :: EventRow -> EventRow -> Ordering
$cp1Ord :: Eq EventRow
Ord,Int -> EventRow -> ShowS
[EventRow] -> ShowS
EventRow -> ErrorMsg
(Int -> EventRow -> ShowS)
-> (EventRow -> ErrorMsg) -> ([EventRow] -> ShowS) -> Show EventRow
forall a.
(Int -> a -> ShowS) -> (a -> ErrorMsg) -> ([a] -> ShowS) -> Show a
showList :: [EventRow] -> ShowS
$cshowList :: [EventRow] -> ShowS
show :: EventRow -> ErrorMsg
$cshow :: EventRow -> ErrorMsg
showsPrec :: Int -> EventRow -> ShowS
$cshowsPrec :: Int -> EventRow -> ShowS
Show)

-- | Scrape header row. Use with the root at @\<tr\>@ tag.
eventRowHeader :: Scraper' EventRow
eventRowHeader :: ScraperT Text Identity EventRow
eventRowHeader = do
  [Text]
tds <- Selector -> ScraperT Text Identity [Text]
forall str (m :: * -> *).
(StringLike str, Monad m) =>
Selector -> ScraperT str m [str]
texts Selector
"td"
  Bool -> ScraperT Text Identity ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> ScraperT Text Identity ())
-> Bool -> ScraperT Text Identity ()
forall a b. (a -> b) -> a -> b
$ [Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
tds Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
4
  -- We cannot use OverloadedStrings with scalpel (as of 0.3.0.1),
  -- because it requires explicit (:: String) declarations everywhere!
  let expected_labels :: [Text]
expected_labels = (ErrorMsg -> Text) -> [ErrorMsg] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ErrorMsg -> Text
pack [ErrorMsg
"Event", ErrorMsg
"When", ErrorMsg
"Where", ErrorMsg
"Deadline"]
  [Int]
-> (Int -> ScraperT Text Identity ()) -> ScraperT Text Identity ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0..([Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
expected_labels Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)] ((Int -> ScraperT Text Identity ()) -> ScraperT Text Identity ())
-> (Int -> ScraperT Text Identity ()) -> ScraperT Text Identity ()
forall a b. (a -> b) -> a -> b
$ \Int
i -> Bool -> ScraperT Text Identity ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> ScraperT Text Identity ())
-> Bool -> ScraperT Text Identity ()
forall a b. (a -> b) -> a -> b
$ Parser Text -> Text -> Bool
forall a. Parser a -> Text -> Bool
parsable (Text -> Parser Text
spacedText (Text -> Parser Text) -> Text -> Parser Text
forall a b. (a -> b) -> a -> b
$ [Text]
expected_labels [Text] -> Int -> Text
forall a. [a] -> Int -> a
!! Int
i) (Text -> Bool) -> Text -> Bool
forall a b. (a -> b) -> a -> b
$ [Text]
tds [Text] -> Int -> Text
forall a. [a] -> Int -> a
!! Int
i
  EventRow -> ScraperT Text Identity EventRow
forall (m :: * -> *) a. Monad m => a -> m a
return EventRow
EventRowHeader

-- | Scrape shortName, URL and longName. Use with the root at @\<tr\>@ tag.
eventRow1 :: Scraper' EventRow
eventRow1 :: ScraperT Text Identity EventRow
eventRow1 = do
  (Text
sname, Text
url) <- Selector
-> ScraperT Text Identity (Text, Text)
-> ScraperT Text Identity (Text, Text)
forall str (m :: * -> *) a.
(StringLike str, Monad m) =>
Selector -> ScraperT str m a -> ScraperT str m a
chroot (TagName
"td" TagName -> [AttributePredicate] -> Selector
@: [AttributeName
"rowspan" AttributeName -> ErrorMsg -> AttributePredicate
@= ErrorMsg
"2"]) (ScraperT Text Identity (Text, Text)
 -> ScraperT Text Identity (Text, Text))
-> ScraperT Text Identity (Text, Text)
-> ScraperT Text Identity (Text, Text)
forall a b. (a -> b) -> a -> b
$ ((,) (Text -> Text -> (Text, Text))
-> ScraperT Text Identity Text
-> ScraperT Text Identity (Text -> (Text, Text))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Selector -> ScraperT Text Identity Text
forall str (m :: * -> *).
(StringLike str, Monad m) =>
Selector -> ScraperT str m str
text Selector
"a" ScraperT Text Identity (Text -> (Text, Text))
-> ScraperT Text Identity Text
-> ScraperT Text Identity (Text, Text)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ErrorMsg -> Selector -> ScraperT Text Identity Text
forall str (m :: * -> *).
(Show str, StringLike str, Monad m) =>
ErrorMsg -> Selector -> ScraperT str m str
attr ErrorMsg
"href" Selector
"a")
  Text
lname <- Selector -> ScraperT Text Identity Text
forall str (m :: * -> *).
(StringLike str, Monad m) =>
Selector -> ScraperT str m str
text (TagName
"td" TagName -> [AttributePredicate] -> Selector
@: [AttributeName
"colspan" AttributeName -> ErrorMsg -> AttributePredicate
@= ErrorMsg
"3"])
  EventRow -> ScraperT Text Identity EventRow
forall (m :: * -> *) a. Monad m => a -> m a
return (EventRow -> ScraperT Text Identity EventRow)
-> EventRow -> ScraperT Text Identity EventRow
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text -> EventRow
EventRow1 Text
sname Text
url Text
lname

-- | Scrape when, where, deadlines in Texts. Use the the root at @\<tr\>@ tag.
eventRow2 :: Scraper' EventRow
eventRow2 :: ScraperT Text Identity EventRow
eventRow2 = do
  [Text]
tds <- Selector -> ScraperT Text Identity [Text]
forall str (m :: * -> *).
(StringLike str, Monad m) =>
Selector -> ScraperT str m [str]
texts Selector
"td"
  Bool -> ScraperT Text Identity ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> ScraperT Text Identity ())
-> Bool -> ScraperT Text Identity ()
forall a b. (a -> b) -> a -> b
$ [Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
tds Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
3
  EventRow -> ScraperT Text Identity EventRow
forall (m :: * -> *) a. Monad m => a -> m a
return (EventRow -> ScraperT Text Identity EventRow)
-> EventRow -> ScraperT Text Identity EventRow
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text -> EventRow
EventRow2 ([Text]
tds [Text] -> Int -> Text
forall a. [a] -> Int -> a
!! Int
0) ([Text]
tds [Text] -> Int -> Text
forall a. [a] -> Int -> a
!! Int
1) ([Text]
tds [Text] -> Int -> Text
forall a. [a] -> Int -> a
!! Int
2)

rowsToEvents_noHeader :: [EventRow] -> Either ErrorMsg [Event]
rowsToEvents_noHeader :: [EventRow] -> Either ErrorMsg [Event]
rowsToEvents_noHeader [] = [Event] -> Either ErrorMsg [Event]
forall (m :: * -> *) a. Monad m => a -> m a
return []
rowsToEvents_noHeader ((EventRow1 Text
sn Text
url Text
ln) : (EventRow2 Text
when Text
wher Text
dl) : [EventRow]
rest) =
  (:) (Event -> [Event] -> [Event])
-> Either ErrorMsg Event -> Either ErrorMsg ([Event] -> [Event])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text
-> Text -> Text -> Text -> Text -> Text -> Either ErrorMsg Event
createEvent Text
sn Text
url Text
ln Text
when Text
wher Text
dl Either ErrorMsg ([Event] -> [Event])
-> Either ErrorMsg [Event] -> Either ErrorMsg [Event]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [EventRow] -> Either ErrorMsg [Event]
rowsToEvents_noHeader [EventRow]
rest
rowsToEvents_noHeader [EventRow]
rows = ErrorMsg -> Either ErrorMsg [Event]
forall a b. a -> Either a b
Left (ErrorMsg
"Error while parsing rows: " ErrorMsg -> ShowS
forall a. [a] -> [a] -> [a]
++ [EventRow] -> ErrorMsg
forall a. Show a => a -> ErrorMsg
show [EventRow]
rows)

-- | TODO: make it configurable.
urlBase :: Text
urlBase :: Text
urlBase = ErrorMsg -> Text
pack ErrorMsg
"http://wikicfp.com"

createEvent :: Text -> Text -> Text -> Text -> Text -> Text -> Either ErrorMsg Event
createEvent :: Text
-> Text -> Text -> Text -> Text -> Text -> Either ErrorMsg Event
createEvent Text
sname Text
url Text
lname Text
when Text
wher Text
dl = do
  Maybe When
when' <- Text -> Either ErrorMsg (Maybe When)
parseWhen Text
when
  Maybe Text
wher' <- Text -> Either ErrorMsg (Maybe Text)
parseWhere Text
wher
  [Day]
dl' <- Text -> Either ErrorMsg [Day]
parseDeadlines Text
dl
  Event -> Either ErrorMsg Event
forall (m :: * -> *) a. Monad m => a -> m a
return Event :: Text -> Text -> Text -> Maybe When -> Maybe Text -> [Day] -> Event
Event { eventShortName :: Text
eventShortName = Text
sname,
                 eventURL :: Text
eventURL = Text
urlBase Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
url,
                 eventLongName :: Text
eventLongName = Text
lname,
                 eventWhen :: Maybe When
eventWhen = Maybe When
when',
                 eventWhere :: Maybe Text
eventWhere = Maybe Text
wher',
                 eventDeadlines :: [Day]
eventDeadlines = [Day]
dl'
               }

-- * Parsers

parsable :: Parser a -> Text -> Bool
parsable :: Parser a -> Text -> Bool
parsable Parser a
p Text
t = (ErrorMsg -> Bool) -> (a -> Bool) -> Either ErrorMsg a -> Bool
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Bool -> ErrorMsg -> Bool
forall a b. a -> b -> a
const Bool
False) (Bool -> a -> Bool
forall a b. a -> b -> a
const Bool
True) (Either ErrorMsg a -> Bool) -> Either ErrorMsg a -> Bool
forall a b. (a -> b) -> a -> b
$ Parser a -> Text -> Either ErrorMsg a
forall a. Parser a -> Text -> Either ErrorMsg a
parseOnly Parser a
p Text
t

spacedText :: Text -> Parser Text
spacedText :: Text -> Parser Text
spacedText Text
expected = Parser ()
skipSpace Parser () -> Parser Text -> Parser Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Text -> Parser Text
string Text
expected Parser Text -> Parser () -> Parser Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
skipSpace Parser Text -> Parser () -> Parser Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
forall t. Chunk t => Parser t ()
endOfInput

spacedText' :: String -> Parser Text
spacedText' :: ErrorMsg -> Parser Text
spacedText' = Text -> Parser Text
spacedText (Text -> Parser Text)
-> (ErrorMsg -> Text) -> ErrorMsg -> Parser Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorMsg -> Text
pack

string' :: String -> Parser Text
string' :: ErrorMsg -> Parser Text
string' = Text -> Parser Text
string (Text -> Parser Text)
-> (ErrorMsg -> Text) -> ErrorMsg -> Parser Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorMsg -> Text
pack

parseWhen :: Text -> Either ErrorMsg (Maybe When)
parseWhen :: Text -> Either ErrorMsg (Maybe When)
parseWhen = Parser (Maybe When) -> Text -> Either ErrorMsg (Maybe When)
forall a. Parser a -> Text -> Either ErrorMsg a
parseOnly (Parser (Maybe When)
parserWhen Parser (Maybe When) -> Parser () -> Parser (Maybe When)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
forall t. Chunk t => Parser t ()
endOfInput) where
  parserWhen :: Parser (Maybe When)
parserWhen = (ErrorMsg -> Parser Text
spacedText' ErrorMsg
"N/A" Parser Text -> Parser (Maybe When) -> Parser (Maybe When)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Maybe When -> Parser (Maybe When)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe When
forall a. Maybe a
Nothing)
               Parser (Maybe When) -> Parser (Maybe When) -> Parser (Maybe When)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (When -> Maybe When
forall a. a -> Maybe a
Just (When -> Maybe When) -> Parser Text When -> Parser (Maybe When)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text When
parserJustWhen)
  parserJustWhen :: Parser Text When
parserJustWhen = Day -> Day -> When
When
                   (Day -> Day -> When)
-> Parser Text Day -> Parser Text (Day -> When)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Parser Text Day
parserDay Parser Text Day -> Parser () -> Parser Text Day
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
skipSpace Parser Text Day -> Parser Text Char -> Parser Text Day
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* (Char -> Parser Text Char
char Char
'-') Parser Text Day -> Parser () -> Parser Text Day
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
skipSpace)
                   Parser Text (Day -> When) -> Parser Text Day -> Parser Text When
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Parser Text Day
parserDay Parser Text Day -> Parser () -> Parser Text Day
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
skipSpace)

parseWhere :: Text -> Either ErrorMsg (Maybe Text)
parseWhere :: Text -> Either ErrorMsg (Maybe Text)
parseWhere = Parser (Maybe Text) -> Text -> Either ErrorMsg (Maybe Text)
forall a. Parser a -> Text -> Either ErrorMsg a
parseOnly (Parser (Maybe Text)
parserWhere Parser (Maybe Text) -> Parser () -> Parser (Maybe Text)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
forall t. Chunk t => Parser t ()
endOfInput) where
  parserWhere :: Parser (Maybe Text)
parserWhere = (ErrorMsg -> Parser Text
spacedText' ErrorMsg
"N/A" Parser Text -> Parser (Maybe Text) -> Parser (Maybe Text)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Maybe Text -> Parser (Maybe Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Text
forall a. Maybe a
Nothing) Parser (Maybe Text) -> Parser (Maybe Text) -> Parser (Maybe Text)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Parser Text -> Parser (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
takeText)

parseDeadlines :: Text -> Either ErrorMsg [Day]
parseDeadlines :: Text -> Either ErrorMsg [Day]
parseDeadlines Text
input = [Day] -> [Day]
forall a. Ord a => [a] -> [a]
sort ([Day] -> [Day]) -> Either ErrorMsg [Day] -> Either ErrorMsg [Day]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser [Day] -> Text -> Either ErrorMsg [Day]
forall a. Parser a -> Text -> Either ErrorMsg a
parseOnly (Parser [Day]
parserDeadlines Parser [Day] -> Parser () -> Parser [Day]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
forall t. Chunk t => Parser t ()
endOfInput) Text
input where
  parserDeadlines :: Parser [Day]
parserDeadlines = Parser [Day]
strictParserDeadlines Parser [Day] -> Parser [Day] -> Parser [Day]
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Parser Text
takeText Parser Text -> Parser [Day] -> Parser [Day]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> [Day] -> Parser [Day]
forall (m :: * -> *) a. Monad m => a -> m a
return [])
  strictParserDeadlines :: Parser [Day]
strictParserDeadlines = do
    Day
primary <- Parser Text Day
parserDay Parser Text Day -> Parser () -> Parser Text Day
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
skipSpace
    Maybe Day
msecondary <- Parser Text Day -> Parser Text (Maybe Day)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Parser Text Day -> Parser Text (Maybe Day))
-> Parser Text Day -> Parser Text (Maybe Day)
forall a b. (a -> b) -> a -> b
$ (Char -> Parser Text Char
char Char
'(' Parser Text Char -> Parser () -> Parser ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
skipSpace Parser () -> Parser Text Day -> Parser Text Day
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text Day
parserDay Parser Text Day -> Parser () -> Parser Text Day
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
skipSpace Parser Text Day -> Parser Text Char -> Parser Text Day
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Text Char
char Char
')')
    [Day] -> Parser [Day]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Day] -> Parser [Day]) -> [Day] -> Parser [Day]
forall a b. (a -> b) -> a -> b
$ [Day] -> (Day -> [Day]) -> Maybe Day -> [Day]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Day
primary] (Day -> [Day] -> [Day]
forall a. a -> [a] -> [a]
: [Day
primary]) Maybe Day
msecondary

parserDay :: Parser Day
parserDay :: Parser Text Day
parserDay = Parser Text Day
impl where
  impl :: Parser Text Day
impl = do
    Int
m <- Parser Text Int
parserMonth Parser Text Int -> Parser () -> Parser Text Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
skipSpace
    Int
d <- Parser Text Int
forall a. Integral a => Parser a
decimal Parser Text Int -> Parser Text (Maybe Char) -> Parser Text Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* (Parser Text Char -> Parser Text (Maybe Char)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Parser Text Char -> Parser Text (Maybe Char))
-> Parser Text Char -> Parser Text (Maybe Char)
forall a b. (a -> b) -> a -> b
$ Char -> Parser Text Char
char Char
',') Parser Text Int -> Parser () -> Parser Text Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
skipSpace
    Integer
y <- Parser Integer
forall a. Integral a => Parser a
decimal
    Day -> Parser Text Day
forall (m :: * -> *) a. Monad m => a -> m a
return (Day -> Parser Text Day) -> Day -> Parser Text Day
forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Day
fromGregorian Integer
y Int
m Int
d
  parserMonth :: Parser Text Int
parserMonth =     (ErrorMsg -> Parser Text
string' ErrorMsg
"Jan" Parser Text -> Parser Text Int -> Parser Text Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Int -> Parser Text Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
1)
                Parser Text Int -> Parser Text Int -> Parser Text Int
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (ErrorMsg -> Parser Text
string' ErrorMsg
"Feb" Parser Text -> Parser Text Int -> Parser Text Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Int -> Parser Text Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
2)
                Parser Text Int -> Parser Text Int -> Parser Text Int
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (ErrorMsg -> Parser Text
string' ErrorMsg
"Mar" Parser Text -> Parser Text Int -> Parser Text Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Int -> Parser Text Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
3)
                Parser Text Int -> Parser Text Int -> Parser Text Int
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (ErrorMsg -> Parser Text
string' ErrorMsg
"Apr" Parser Text -> Parser Text Int -> Parser Text Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Int -> Parser Text Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
4)
                Parser Text Int -> Parser Text Int -> Parser Text Int
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (ErrorMsg -> Parser Text
string' ErrorMsg
"May" Parser Text -> Parser Text Int -> Parser Text Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Int -> Parser Text Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
5)
                Parser Text Int -> Parser Text Int -> Parser Text Int
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (ErrorMsg -> Parser Text
string' ErrorMsg
"Jun" Parser Text -> Parser Text Int -> Parser Text Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Int -> Parser Text Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
6)
                Parser Text Int -> Parser Text Int -> Parser Text Int
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (ErrorMsg -> Parser Text
string' ErrorMsg
"Jul" Parser Text -> Parser Text Int -> Parser Text Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Int -> Parser Text Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
7)
                Parser Text Int -> Parser Text Int -> Parser Text Int
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (ErrorMsg -> Parser Text
string' ErrorMsg
"Aug" Parser Text -> Parser Text Int -> Parser Text Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Int -> Parser Text Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
8)
                Parser Text Int -> Parser Text Int -> Parser Text Int
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (ErrorMsg -> Parser Text
string' ErrorMsg
"Sep" Parser Text -> Parser Text Int -> Parser Text Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Int -> Parser Text Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
9)
                Parser Text Int -> Parser Text Int -> Parser Text Int
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (ErrorMsg -> Parser Text
string' ErrorMsg
"Oct" Parser Text -> Parser Text Int -> Parser Text Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Int -> Parser Text Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
10)
                Parser Text Int -> Parser Text Int -> Parser Text Int
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (ErrorMsg -> Parser Text
string' ErrorMsg
"Nov" Parser Text -> Parser Text Int -> Parser Text Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Int -> Parser Text Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
11)
                Parser Text Int -> Parser Text Int -> Parser Text Int
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (ErrorMsg -> Parser Text
string' ErrorMsg
"Dec" Parser Text -> Parser Text Int -> Parser Text Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Int -> Parser Text Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
12)