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 Lentil.Parse.Source (commentParser)

import Text.Parsec
import qualified Text.Parsec.Pos as P

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

import qualified Data.Char as C
import qualified Data.List as L
import qualified Data.Either as E
import qualified System.IO as I


-- TODO: eliminate lookahead? fai il parser davvero da bottom up senza sub
--       parsing [lint] [refactor] ?
-- TODO: e che fare quando il todo segue un * come nei commenti lunghi c? [design]


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

type ParIssue a = Parsec String ParState a

-- file we are parsing
data ParState = ParState { psPath    :: FilePath }



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

-- todo add blankline to ancillaries? [lint]
-- 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 ()
incipit = () <$ ( char '\n'                       *>
                  spaces                          *>
                  choice (map ciString flagWords) *>
                  optional (char ':')             *>
                  many1 (char ' ')                   )
          <?> "incipit"

-- TODO: allow tags in before description? [doc] [design]
flagWords :: [String]
flagWords = ["TODO", "FIXME", "XXX"]


------------
-- 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 = (Issue <$> fmap psPath getState
               <*> (incipit *> fmap sourceLine getPosition)
               <*> freeText
               <*> option [] (try tags))
        <?> "issue"


-- 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
          end       = lookAhead $ choice [vp (spaces *> tag),
                                          vp blankline,
                                          vp incipit]

    -- todo rimuovi tutti gli eof, oramai non servono [refactor]

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




-- parses a number of issues from a given line-of-text
issues :: ParIssue [Issue]
issues = getPosition >>= \p -> -- horrible hack, search for [duct] for expl-
         setPosition (setSourceLine p (0)) >> -- anation
         many (try $ manyTill anyChar (lookAhead $ try incipit) *> issue)
         <?> "issues"


----------
-- FILE --
----------

-- main function with wich to parse issues; errors on stderr
issueFinder :: [FilePath] -> IO [Issue]
issueFinder fps = mapM commentParser fps >>= \content ->

                  -- todo partial pattern! [refactor] [lint]
                  let ass = zip fps content
                      con' = map (\(a, Just b) -> (a,b)) .
                             filter ((/= Nothing) . snd) $ ass in
                  mapM pf con' >>= \iss ->

                  return (concat iss)
    where
          pf (fp,cs) = case runParSource issues fp cs of
                         Left l  -> perr (fp ++ " : issue parsing error " ++
                                          show l) >> return []
                         Right r -> return r

          perr cs = I.hPutStrLn I.stderr cs

-- todo deduplicate runparsource [lint] [refactor]
runParSource :: ParIssue a -> FilePath -> String -> Either ParseError a
runParSource p fp cs = runParser p (ParState fp) fp cs