Issue.hs

-----------------------------------------------------------------------------
-- |
-- Module      :  Lentil.Parse.Issue
-- Copyright   :  © 2015-2016 Francesco Ariis, Michał Antkiewi
-- License     :  GPLv3 (see the LICENSE file)
--
-- Issues parsing from comments
-----------------------------------------------------------------------------

module Lentil.Parse.Issue where

import Lentil.Types

import Text.Parsec

import Control.Applicative hiding ( (<|>), optional, many )

import qualified Data.Char as C

import Prelude -- 7.8 hack


-----------
-- TYPES --
-----------

type ParIssue a = Parsec String [FlagWord] a

-- standard flagwords
stdFlagwords :: [FlagWord]
stdFlagwords = ["todo", "fixme", "xxx"]

-- top-level constant to evaluate once
flagWords :: ParIssue [FlagWord]
flagWords = fmap (stdFlagwords ++) getState

---------------
-- PRIMITIVE --
---------------

-- a unix file is defined as many lines (each one ended by '\n')
-- this parser captures the definition and can be used as eof replacement too
eoft :: ParIssue ()
eoft = optional (char '\n') *> eof

-- case insensitive string, lifted from Text.ParserCombinators.Parsec.Rfc2234
ciString :: String -> ParIssue String
ciString s = mapM ciChar s <?> "case insensitive string"
    where ciChar :: Char -> ParIssue Char
          ciChar c = char (C.toLower c) <|> char (C.toUpper c)

-- i.e. remove unneeded whitespace
htmlify :: String -> String
htmlify cs = unwords . words $ cs

-- a blank line of text (even at eof)
blankline :: ParIssue ()
blankline = char '\n' *> (() <$ char '\n' <|> eof)


----------
-- TAGS --
----------

-- simple tags parsing

-- tag only
tag :: ParIssue Tag
tag = Tag <$> (openPar *> tagLabel <* closePar) <?> "tag"

-- anything goes, apart from ' '
tagLabel :: ParIssue String
tagLabel = many1 (satisfy sf) <?> "tag label"
    where sf :: Char -> Bool
          sf c | c == closeDel = False
               | C.isSpace c   = False
               | otherwise     = True

openPar, closePar :: ParIssue Char
openPar  = char openDel  <?> "open-tag delimiter"
closePar = char closeDel <?> "close-tag delimiter"


-------------
-- INCIPIT --
-------------

-- optional ws + flagwords (case unsensitive) + optional ':' ++ optional1 ws
-- incipit have to be bound at the beginning of line (won't pick up stuff
-- in the middle of a sentence)
incipit :: ParIssue FlagWord
incipit = char '\n' >> spaces           >>
          fwpar                         >>= \fw ->
          optional (char ':')           >>
          notFollowedBy nonSpace        >> -- real todo, not todoodle
          return (normaliseFlagword fw)
          <?> "incipit"
    where
          fwpar = flagWords                        >>= \fw ->
                  choice (map (try . ciString) fw)

          nonSpace = satisfy (not . C.isSpace)


------------
-- ISSUES --
------------

-- simple issue parsing

-- an issue is a flagword, followed by : , followed by some description and
-- ended optionally by some tags (No t/f? End by whiteline or eof or
-- another TODO).
-- tags can be placed *before* description, too
issue :: ParIssue Issue
issue = (mkIssue <$> incipit
                 <*> fmap sourceName getPosition
                 <*> fmap sourceLine getPosition
                 <*> option [] (try tags)
                 <*> freeText
                 <*> option [] (try tags))
        <?> "issue"
    where
          mkIssue fw fp ln tg1 ds tg2 = Issue fp ln ds (addTag fw (tg1++tg2))

          addTag "todo" tgs = tgs
          addTag fw     tgs = Tag fw : tgs



-- any text. Since tags/fields at the end of the issue are optional, we need
-- a way to delimit this. Delimiters are: eof, tags/fields, blank line
freeText :: ParIssue (Maybe Description)
freeText = fmap htmlify (manyTill anyChar end) >>= \t ->
           case t of
             [] -> return Nothing
             _  -> return $ Just t

         <?> "free text"
    where vp p      = try . parsecMap (const ()) $ p
          end       = lookAhead $ choice [vp (spaces1 *> tag),
                                          vp blankline, -- \n\n or \neof
                                          vp incipit,   -- another issue
                                          vp eof]
          spaces1 = space *> spaces

tags :: ParIssue [Tag]
tags = many1 (try $ spaces *> tag) <?> "tags"


-- parses a number of issues from a given line-of-text
issues :: ParIssue [Issue]
issues = many (try $ manyTill anyChar (lookAhead $ try incipit) *> issue)
         <?> "issues"