gistfile1.hsc

import Text.Parsec hiding (many, optional, (<|>))
import qualified Text.Parsec.Token as T
import qualified Text.Parsec.Language as L
import Control.Applicative
import Data.Char (isSpace)
import Maybe (isJust)
import Types

-- For efficiency, we will bind all the used lexical parsers at toplevel
lexer = T.makeTokenParser L.emptyDef
parens = T.parens lexer
comma = T.comma lexer
colon = T.colon lexer
naturalOrFloat = T.naturalOrFloat lexer
symbol = T.symbol lexer
whiteSpace = T.whiteSpace lexer

-- Util functions
stripr :: String -> String
stripr = reverse . p . reverse -- . p
  where
    p = dropWhile isSpace

-- Parser(s)
commandParser = Command 
                <$> (char '@' *> many alphaNum) 
                <*> optional (parens (many alphaNum `sepBy` comma))
                <*> (colon *> (do xs <- many (noneOf ":\n") `sepBy` symbol "::"
                                  return $ map stripr xs))

attrParser = (,) 
             <$> optional 
                 (oneOf "LMH" <* (comma <|> (eof *> return "")))
             <*> optional ((try (manyTill (noneOf ",") comma) 
                                    *> (naturalOrFloat <* eof)) 
                           <|> (naturalOrFloat <* eof))

type RawTagEntry = String
type TagEntryError = String

{-
class RawTagParsable a where
    parseRawEntries :: FilePath -> IO [a]
-}

parseCommand :: RawTagEntry -> Either ParseError Command
parseCommand rt = parse (do {whiteSpace;commandParser}) "cmd" rt

class TagParseable a where
    cmd2entry :: Command -> Either TagEntryError a

    parseTagEntry :: RawTagEntry 
                     -> Either ParseError (Either TagEntryError a)
    parseTagEntry rt = cmd2entry <$> parseCommand rt

instance TagParseable TodoEntry where
    cmd2entry = cmd2todo

cmd2todo :: Command -> Either TagEntryError TodoEntry
cmd2todo (Command _ ul attrs)  
    | len == 0 || len > 3 = Left "Required: 1 to 3 command attributes"
    | otherwise           = either (Left . show) 
                                   (\_ -> Right $ TodoEntry mil act ul pri ts) 
                                   attr
  where
    aParser = parse attrParser "attr"
    len = length attrs
    mil = case (len, isJust pri || isJust ts) of
            (1, _)    -> Nothing
            (2, True) -> Nothing
            _         -> Just $ head attrs
    act = case (len, isJust pri || isJust ts) of
            (1, _)    -> head attrs
            (2, True) -> head attrs
            _         -> head $ tail attrs
    attr = case len of
             2 -> aParser (head $ tail attrs)
             3 -> aParser (head $ tail $ tail attrs)
             _ -> Right (Nothing, Nothing)
    (pri, ts) = either (\_ -> (Nothing, Nothing)) (\x -> x) attr