hirt-0.0.1.0: Parse.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TupleSections #-}
module Parse where

import Types

import Control.Applicative
import Control.Monad
import Data.Attoparsec.Text
import Data.Char
import Data.List
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.IO as T

skipLine :: Parser ()
skipLine = skipWhile (not . isEndOfLine) >> endOfLine

spaceyEndOfLine :: Parser ()
spaceyEndOfLine = skipWhile (\x -> isSpace x && (not . isEndOfLine) x) >> endOfLine

class Parseable a where
    names :: a -> [T.Text]
    parser :: Parser a

instance Parseable AB where
    names _ = ["a", "b"]
    parser = (,) <$> double <* skipSpace <*> double

instance Parseable ABC where
    names _ = ["a", "b", "c"]
    parser = (,,) <$> double <* skipSpace <*> double <* skipSpace <*> double

headable :: Parser () -> Parser a -> Parser a
headable header list = (header >> list) <|> list

line :: [T.Text] -> Parser ()
line xs = (sequence . map name $ xs) >> skipLine
    where name n = skipSpace >> string n

responsesParser :: Parser [(Contestant, Task, Points)]
responsesParser = headable header list <* endOfInput
  where
    header = line ["contestant", "task", "result"]
    list = many $ do
    skipSpace
    c <- takeTill isSpace <* skipSpace
    t <- takeTill isSpace <* skipSpace
    r <- double <* endOfLine
    return (c, t, r > 0)

thetasParser :: Parser [(Contestant, Theta)]
thetasParser = headable header list <* endOfInput
  where
    header = line ["theta"]
    list = many $ do
    skipSpace
    c <- takeTill isSpace <* skipSpace
    t <- double <* skipLine
    return (c, t)

taskParamParser :: Parser (Task, TaskParam)
taskParamParser = do
    t <- takeTill isSpace <* skipSpace
    p <- parser
    return (t,p)

taskParamsParser :: [Task] -> Parser [(Task, TaskParam)]
taskParamsParser tasks = headable header list <* endOfInput
  where
    header = line $ names (undefined :: TaskParam)
    list = matchList paramsParser <|> (matchList $ many $ (taskParamParser <* skipLine))
    matchList p = do
        xs <- p
        when (length xs /= length tasks) $
            fail $ "expecting " ++ (show $ length tasks)
                 ++ " tasks while " ++ (show $ length xs) ++ " found."
        when ((sort $ map fst xs) /= (sort tasks)) $
            fail "task names do not match"
        return xs

    paramsParser = do
        ps <- many $ parser <* endOfLine
        return $ zip (tasks ++ repeat "") ps

twologParser :: Parser [TaskParam]
twologParser = do
    _ <- manyTill (skipWhile (not . isEndOfLine) >> endOfLine) endOfLine
    many $ parser <* spaceyEndOfLine

justParse :: Parser a -> Text -> a
justParse p s = case parseOnly p s of
    Left e -> error e
    Right r -> r

fromFile :: Parser a -> FilePath -> IO a
fromFile p f = fmap (justParse p) (T.readFile f)