1 files changed, 92 insertions, 0 deletions
diff --git a/src/Model/EventParser.hs b/src/Model/EventParser.hs
new file mode 100644
index 0000000..7a9955f
--- /dev/null
+++ b/src/Model/EventParser.hs
@@ -0,0 +1,92 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Model.EventParser
+  ( parseEvents
+  ) where
+
+import Control.Arrow (left)
+
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Maybe (catMaybes)
+
+import Text.ParserCombinators.Parsec
+import Text.Parsec.Char (endOfLine)
+
+import Model.Event (Event, Event(Event))
+import qualified Model.Event as Event
+import Model.Date (Date(Date))
+import qualified Model.Date as Date
+
+parseEvents :: Text -> Either Text [Event]
+parseEvents input =
+  left (T.pack . show) (parse eventsParser "" (T.unpack input)) >>= validateEvents
+
+validateEvents :: [Event] -> Either Text [Event]
+validateEvents events =
+  let invalid = filter (not . Date.isValid . Event.date) events
+  in  if null invalid
+        then
+          Right events
+        else
+          Left $
+             T.concat
+               [ "Invalid events: "
+               , T.intercalate ", " (map Event.renderEvent invalid)
+               ]
+
+eventsParser :: Parser [Event]
+eventsParser = concat <$> many monthSection
+
+monthSection :: Parser [Event]
+monthSection = do
+  month <- monthSectionTitle
+  spaces
+  events <- catMaybes <$> many lineParser
+  return $
+    map (\(day, year, name) ->
+      Event (Date day month year) name
+    ) events
+
+lineParser :: Parser (Maybe (Int, Int, Text))
+lineParser =
+  (Just <$> eventParser <* endOfLine)
+  <|> (comment >> return Nothing)
+  <|> (emptyLine >> return Nothing)
+
+monthSectionTitle :: Parser Int
+monthSectionTitle = char '[' *> monthParser <* char ']'
+
+monthParser :: Parser Int
+monthParser =
+      (try $ string "January" >> return 1)
+  <|> (try $ string "February" >> return 2)
+  <|> (try $ string "March" >> return 3)
+  <|> (try $ string "April" >> return 4)
+  <|> (try $ string "May" >> return 5)
+  <|> (try $ string "June" >> return 6)
+  <|> (try $ string "July" >> return 7)
+  <|> (try $ string "August" >> return 8)
+  <|> (try $ string "September" >> return 9)
+  <|> (try $ string "October" >> return 10)
+  <|> (try $ string "November" >> return 11)
+  <|> (try $ string "December" >> return 12)
+
+eventParser :: Parser (Int, Int, Text)
+eventParser =
+  (,,) <$>
+    integerParser <* separator ',' <*>
+    integerParser <* separator ':' <*>
+    (T.strip . T.pack <$> many (noneOf "\n"))
+
+separator :: Char -> Parser ()
+separator c = many (char ' ') >> char c >> many (char ' ') >> return ()
+
+integerParser :: Parser Int
+integerParser = (read :: String -> Int) <$> many1 digit
+
+emptyLine :: Parser ()
+emptyLine = skipMany (char ' ') >> endOfLine >> return ()
+
+comment :: Parser ()
+comment = char '#' >> many (noneOf "\n") >> endOfLine >> return ()