Issue.hs

-----------------------------------------------------------------------------
-- |
-- Module      :  Lentil.Parse.Issue
-- Copyright   :  © 2015 Francesco Ariis
-- 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


-- TODO: e che fare quando il todo segue un * come nei commenti
--       lunghi c? [design]


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

type ParIssue a = Parsec String () a

-- issue flagword
data FlagWord = Todo | Fixme | Xxx deriving (Show, Enum, Eq)

fw2s :: FlagWord -> String
fw2s Todo  = "todo"
fw2s Fixme = "fixme"
fw2s Xxx   = "xxx"

s2fw :: String -> FlagWord
s2fw s = case map C.toLower s of
           "todo"  -> Todo
           "fixme" -> Fixme
           "xxx"   -> Xxx
           e       -> error ("unrecognised fw: " ++ e)


---------------
-- 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


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

-- TODO: add this to (ciString ancillaries?) [refactor]
-- 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)
-- blankline = () <$ string "\n\n"


----------
-- 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 :: ParIssue FlagWord
incipit = fwpar               >>= \fw ->
          optional (char ':') >>
          many1 (char ' ')    >> -- fixme usa spaces non ' '
          return fw
          <?> "incipit"
    where
          flagWords = map fw2s (enumFrom Todo)

          fwpar = choice (map ciString flagWords) >>=
                  return . s2fw


------------
-- 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).
issue :: ParIssue Issue
issue = (mkIssue <$> incipit
                 <*> fmap sourceName getPosition
                 <*> (fmap sourceLine getPosition)
                 <*> freeText
                 <*> option [] (try tags))
        <?> "issue"
    where
          mkIssue fw fp ln ds tgs = Issue fp ln ds (addTag fw tgs)

          addTag Todo tgs = tgs
          addTag fw   tgs = (Tag $ fw2s 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 Description
freeText = fmap htmlify (manyTill anyChar end) <?> "free text"
    where vp p      = try . parsecMap (const ()) $ p
          nlInc     = char '\n' *> spaces >> incipit
          end       = lookAhead $ choice [vp (spaces *> tag),
                                          vp blankline,
                                          vp nlInc,
                                          vp eof] -- fixme specifica meglio

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"