lentil 0.1.0.1 → 0.1.0.2
raw patch · 2 files changed
+326/−2 lines, 2 filesdep ~base
Dependency ranges changed: base
Files
- lentil.cabal +2/−2
- src/Lentil/Parse.hs +324/−0
lentil.cabal view
@@ -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
+ src/Lentil/Parse.hs view
@@ -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 "<block-parse>" 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 "<source>"+ -- 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]