diff --git a/lentil.cabal b/lentil.cabal --- a/lentil.cabal +++ b/lentil.cabal @@ -1,5 +1,5 @@ name: lentil -version: 0.1.0.1 +version: 0.1.0.2 synopsis: frugal issue tracker description: minumum effort, cohesive issue tracker for the rest of us. Check homepage for manual, tutorial. @@ -25,7 +25,7 @@ ansi-wl-pprint >= 0.6 && < 0.7, csv >= 0.1 && < 0.2 other-modules: Lentil.Types, Lentil.Args, Lentil.File, Lentil.Print, - Lentil.Query, Lentil.Export + Lentil.Query, Lentil.Export, Lentil.Parse hs-source-dirs: src diff --git a/src/Lentil/Parse.hs b/src/Lentil/Parse.hs new file mode 100644 --- /dev/null +++ b/src/Lentil/Parse.hs @@ -0,0 +1,324 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Lentil.Parse.Source +-- Copyright : © 2015 Francesco Ariis +-- License : GPLv3 (see the LICENSE file) +-- +-- Issues parsing from source. +----------------------------------------------------------------------------- + +module Lentil.Parse where + +import Lentil.Types + +import Text.Parsec + +import Control.Applicative hiding ( (<|>), optional, many ) + +import qualified Data.Char as C +import qualified Data.List as L +import qualified System.FilePath as SF +import qualified System.Directory as D +import qualified System.IO as I +import qualified Data.Either as E + + +-- TODO: eliminate lookahead? fai il parser davvero da bottom up senza sub +-- parsing [lint] [refactor] ? + + +----------- +-- TYPES -- +----------- + +type ParSource = Parsec String ParState + +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 :: ParSource () +eoft = optional (char '\n') *> eof + +-- i.e. remove unneeded whitespace +htmlify :: String -> String +htmlify cs = unwords . words $ cs + + +-- occhio che il primo carattere non è controllato da ED +-- TODO: manyTill1 broken? occhio che al primon on chiama ed! [test] +manyTill1 :: ParSource a -> ParSource b -> ParSource [a] +manyTill1 p ed = (:) <$> p <*> manyTill p ed + + +---------- +-- TAGS -- +---------- + +-- simple tags parsing + +-- tag only +tag :: ParSource Tag +tag = Tag <$> (openPar *> tagLabel <* closePar) "tag" + +-- anything goes, apart from ' ' +tagLabel :: ParSource String +tagLabel = many1 (satisfy sf) "tag label" + where sf :: Char -> Bool + sf c | c == closeDel = False + | C.isSpace c = False + | otherwise = True + +openPar, closePar :: ParSource Char +openPar = char openDel "open-tag delimiter" +closePar = char closeDel "close-tag delimiter" + + +------------ +-- ISSUES -- +------------ + +-- simple issue parsing + +-- parses a number of issues from a given line-of-text +issues :: ParSource [Issue] +issues = many (try $ manyTill anyChar (lookAhead $ try incipit) *> issue) + "issues" + +-- 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 :: ParSource Issue +issue = Issue <$> fmap psPath getState + <*> fmap sourceLine getPosition + <*> (incipit *> fmap htmlify freeText) + <*> (optional spaces *> option [] (try tags)) + "issue" + + +-- flagwords + ": " +incipit :: ParSource () +incipit = () <$ (choice (map string flagWords) *> string ": ") "incipit" + +flagWords :: [String] +flagWords = ["TODO", "FIXME", "NOTE", "XXX"] + +tags :: ParSource [Tag] +tags = sepEndBy1 tag spaces "tags" + +-- 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, new issue +freeText :: ParSource Description +freeText = manyTill anyChar end "free text" + where vp p = try . parsecMap (const ()) $ p + end = lookAhead $ choice [vp (spaces *> tag), + vp (spaces *> incipit), vp eoft] + + +------------ +-- BLOCKS -- +------------ + +-- blocks parsing, check `block` comment for more info + +blocks :: ParSource [Issue] +blocks = concat <$> many1 block + +-- a block is some text separated by emptyline(s) (a paragraph). Once you +-- parse it you need to unwrap it and scan for comments. Whitespace +-- is treated like in html. +block :: ParSource [Issue] +block = getPosition >>= \lep -> + manyTill1 anyChar (try $ emptyline <|> eoft) >>= \rb -> + getState >>= \ps -> + case runParser (bi lep) ps "" rb of + Right r -> return r + Left l -> parserFail ("block subp: " ++ show l) + "block" + where + bi p = setPosition p >> issues + + +emptyline :: ParSource () +emptyline = () <$ (endOfLine *> many (satisfy ws) *> endOfLine) "emptyline" + where ws c = C.isSpace c && notElem c "\n\r\f\v" + -- as per definition of isSpace in Data.Char + + +-------------- +-- COMMENTS -- +-------------- + +-- TYPES -- + +-- StringPos is the comment itself + its indentation level. Conventionally +-- multiline comments will have IL of 0 to sever them from single line +-- comments +type StringPos = (Int, Int, String) -- Col, Row, String + + +-- FUNCTIONS -- + +-- Comment is the same, with just line indication, for comments that go +-- together indentation wise. Check the utility function sps2cr +type CommentRow = (Int, String) -- row, String + +sps2cr :: [[StringPos]] -> [CommentRow] +sps2cr sps = map sp2cr sps + where sp2r (_,r,_) = r + sp2s (_,_,s) = s + + sp2cr [] = error "empty group in sps2cr" + sp2cr zs = (sp2r . head $ zs, myUnlines . map sp2s $ zs) + + -- do not add unneeded \n at end + myUnlines zs = L.intercalate "\n" zs + + +-- comments: from a source file to something parsable by `blocks` +-- indent level 0, to recognise them from single line +multiLine :: String -> String -> ParSource StringPos +multiLine st ed = getPosition >>= \a -> + (,,) <$> pure 0 + <*> pure (sourceLine a) + <*> (string st *> manyTill anyChar (try $ string ed)) + "multiline comment" + +-- returns single line comment and starting column of such comment +singleLine :: String -> ParSource StringPos -- int: starting col +singleLine st = getPosition >>= \a -> + (string st *> manyTill anyChar (() <$ endOfLine <|> eoft)) >>= \s -> + return (sourceColumn a, sourceLine a, s) + "singleline comment" + + +rawComment :: String -> String -> String -> ParSource StringPos +rawComment st ed slt = try (multiLine st ed) <|> singleLine slt + "raw comment" + +rawComments :: String -> String -> String -> + ParSource [StringPos] +rawComments st ed slt = + E.rights <$> many1 ( try (Right <$> rawComment st ed slt) <|> + try (Left <$> (() <$ codeString)) <|> + (Left <$> other ) ) + -- TODO: o many? [test] + "raw comments" + where + initP = lookAhead (try (() <$ string st)) <|> -- long comment + lookAhead (try (() <$ string slt)) <|> -- line comment + lookAhead (() <$ char '"') <|> -- code string + (() <$ char '\n') -- TODO: use eoft [bug] + + -- non comment stuff + other = () <$ manyTill anyChar initP -- XXX + +-- quoted strings, by mauke^ +codeString :: ParSource String +codeString = q *> many ((char '\\' *> anyChar) <|> noneOf "\"\\") <* q + "codestring" + where q = char '"' + +-- single lineblock (which will be parsed) plus its original row position +groupStringPos :: [StringPos] -> [CommentRow] +groupStringPos sps = + let grp = L.groupBy sameBlock sps' + -- sps'': now that they are grouped, go back to sp tuple + c2s qs = map (\(c,r,s,_) -> (c,r,s)) qs + sps'' = map c2s grp -- this is a list of lists, hence + -- the doublemap + in sps2cr sps'' + where -- how to verify if lines are sequential? + -- subtract [1..] to line-number and you can use Eq on this! + + -- clever hack, the subtraction is the 4th value of the tuple + sps' = map (\((c,r,s),k) -> (c,r,s,r-k)) (zip sps [1..]) + + -- equality function: + -- multiline blocks are always to be treated alone + -- single line blocks are to be grouped only if on same col and + -- sequential lines + sameBlock (0,_,_,_ ) _ = False + sameBlock (c,_,_,il) (c',_,_,il') = c == c' && il == il' + + +------------ +-- SOURCE -- +------------ + +source :: String -> String -> String -> ParSource [Issue] +source st ed slt = fmap groupStringPos (rawComments st ed slt) >>= \cc -> + fmap psPath getState >>= \fp -> + fmap concat (mapM (parseCr fp) cc) + where + parseCr :: FilePath -> CommentRow -> ParSource [Issue] + parseCr fp (r,s) = case runParSource (bpp r) fp s of + Right y -> pure y + Left _ -> parserFail "" + -- TODO: more meaningful err mes. [duct] + bpp r = getPosition >>= \p -> + setPosition (setSourceLine p r) >> + blocks + -- TODO: elimina runParser per runParSource [duct] + + +---------- +-- FILE -- +---------- + +-- main function with wich to parse issues; errors on stderr +issueFinder :: [FilePath] -> IO [Issue] +issueFinder fps = concat <$> mapM (uncurry fileParser) (matchPar fps) + where -- matches each file w/ its parser, filters parserless files + matchPar :: [FilePath] -> [(FilePath, ParSource [Issue])] + matchPar fpz = filtNotPar . map (\f -> (f, langParser f)) $ fpz + + -- I can't use == on ParSource + filtNotPar :: [(FilePath, Maybe (ParSource [Issue]))] -> + [(FilePath, ParSource [Issue])] + filtNotPar [] = [] + filtNotPar ((f, Just p):tps) = (f,p) : filtNotPar tps + filtNotPar ((_, Nothing):tps) = filtNotPar tps + + +fileParser :: FilePath -> ParSource [Issue] -> IO [Issue] +fileParser fp p = rfe fp >>= \cs -> + case runParSource p fp cs of + Left l -> perr (fp ++ " : parse error " ++ show l) >> + return [] + Right r -> return r + where rfe :: FilePath -> IO String + rfe _ = D.doesFileExist fp >>= \fb -> + if fb then readFile fp + else perr (fp ++ " : no such file") >> return "" + + perr cs = I.hPutStrLn I.stderr cs + +runParSource :: ParSource a -> FilePath -> String -> Either ParseError a +runParSource p fp cs = runParser p (ParState fp) fp cs + +-- TODO: add more langparsers [feature:intermediate] +langParser :: FilePath -> Maybe (ParSource [Issue]) +langParser fp | ext `elem` [".hs", ".lhs"] = Just haskell + | ext `elem` [".c", ".h"] = Just c + | ext `elem` [".txt"] = Just blocks + | otherwise = Nothing + where ext = SF.takeExtension fp + + haskell = source "{-" "-}" "--" + c = source "/*" "*/" "//" + -- Shell: # (Perl: same) + -- php: as C + Shell + -- ruby: shell and =begin =end + -- javascript: C + html + -- python: # and """ + -- java, objective-c, etc. watch tiobe + -- html + + -- TODO: do not add more languages but parse every text + -- file? [design] [u:3]