diff --git a/changes.txt b/changes.txt --- a/changes.txt +++ b/changes.txt @@ -1,8 +1,15 @@ +1.3.0.0 +------- + +- Released Thu 30 May 2019 11:35:50 CEST +- Fixed memory explosion on big repos (reported by qptain nemo) + 1.2.3.0 ------- - Released Mon 13 May 2019 16:15:19 CEST - Added PureScript syntax (request by Adrian Sieber) + 1.2.2.0 ------- diff --git a/issues.txt b/issues.txt --- a/issues.txt +++ b/issues.txt @@ -8,16 +8,22 @@ skipped?) [request] [2017] src/Lentil/File.hs - 77 combine funziona su windows? [test] + 71 combine funziona su windows? [test] src/Lentil/Parse/Run.hs - 131 Row should be carried on by issues, not be manually set! [refactor] + 147 Row should be carried on by issues, not be manually set! [refactor] + 175 check progressbar documentation for proper usage ... :: IO + ProgressBar [waring] src/Lentil/Parse/Syntaxes.hs 25 qptain_nemo fake multiline comments in C (i.e. // and \ at the bottom of the line, continued into next line, are valid C comments but not recognised by lentil [u:1] [request] - 101 rst parser doesn't respect whitespace or paragraphs. How to + 31 (Iustin Pop) export to markdown. [u:1] [request] + 32 scanner for yesod templates (hamlet/julius/casius) which are a bit + difficult since they are html/js/css + embedded Haskell. [u:1] + [request] + 107 rst parser doesn't respect whitespace or paragraphs. How to implement this without breaking other parsers? [bug] [design] src/Main.hs diff --git a/lentil.cabal b/lentil.cabal --- a/lentil.cabal +++ b/lentil.cabal @@ -1,5 +1,5 @@ name: lentil -version: 1.2.3.0 +version: 1.3.0.0 synopsis: frugal issue tracker description: minumum effort, cohesive issue tracker based on ubiquitous @TODO@s and @FIXME@s conventions. @@ -62,6 +62,8 @@ build-depends: base >= 4.9 && < 5.0, ansi-wl-pprint==0.6.*, csv==0.1.*, + deepseq==1.4.*, + dlist==0.8.*, directory >= 1.2 && < 1.4, filemanip==0.3.*, filepath==1.4.*, @@ -69,7 +71,6 @@ mtl == 2.2.*, natural-sort==0.1.*, optparse-applicative >= 0.13 && < 0.15, - pipes >= 4.2 && < 4.4, regex-tdfa==1.2.*, semigroups==0.18.*, text==1.2.*, @@ -98,13 +99,14 @@ ansi-wl-pprint==0.6.*, csv==0.1.*, directory >= 1.2 && < 1.4, + deepseq==1.4.*, + dlist==0.8.*, filemanip==0.3.*, filepath==1.4.*, megaparsec==7.0.*, mtl == 2.2.*, natural-sort==0.1.*, optparse-applicative >= 0.13 && < 0.15, - pipes >= 4.2 && < 4.4, regex-tdfa==1.2.*, semigroups==0.18.*, text==1.2.*, diff --git a/src/Lentil/Export.hs b/src/Lentil/Export.hs --- a/src/Lentil/Export.hs +++ b/src/Lentil/Export.hs @@ -51,6 +51,12 @@ file = prettyFP . iFile groupBy = L.groupBy ((==) `on` file) +-- markdown output +-- - che genere di header? o lista di liste? +-- - come mettere i tag? /[[cdsacad] [cdsac]/ +-- - lista? minuses +-- - wrap at 80? sì +-- - cmark ----------------- -- ANCILLARIES -- diff --git a/src/Lentil/File.hs b/src/Lentil/File.hs --- a/src/Lentil/File.hs +++ b/src/Lentil/File.hs @@ -10,7 +10,6 @@ module Lentil.File where -import Lentil.Helpers import Lentil.Types import Lentil.Parse.Run import Lentil.Parse.Syntaxes @@ -18,12 +17,10 @@ import System.FilePath import System.FilePath.Find import Control.Applicative -import Pipes import Data.Semigroup as S import Data.Monoid as M () import qualified Data.List as L -import qualified Pipes.Prelude as PP --------------- @@ -45,15 +42,10 @@ findIssues :: [Alias] -> [FlagWord] -> [FilePath] -> [FilePath] -> IO [Issue] findIssues as fws fps xs = - findFiles as fps xs >>= \fl -> - fmap concat (PP.toListM $ finalPipe fl) >>= \r -> - perrEph "\r" >> -- clean progress bar + findFiles as fps xs >>= \fl -> + issueFinder as fws fl >>= \r -> return r where - finalPipe fl = prod fl >-> issLoop fl - - prod fl = each (zip fl [1..]) - issLoop fl = issueFinder as fws (length fl) >> issLoop fl -- actual find function for IO () findFiles :: [Alias] -> [FilePath] -> [FilePath] -> IO [FilePath] diff --git a/src/Lentil/Helpers.hs b/src/Lentil/Helpers.hs --- a/src/Lentil/Helpers.hs +++ b/src/Lentil/Helpers.hs @@ -24,12 +24,6 @@ perr :: String -> IO () perr cs = I.hPutStrLn I.stderr cs --- output errors (to stderr), but without newline *and* calling /r --- (erase what's before) first -perrEph :: String -> IO () -perrEph cs = I.hPutStr I.stderr ("\r" ++ cs) - - ------------- -- PARSING -- ------------- diff --git a/src/Lentil/Parse/Run.hs b/src/Lentil/Parse/Run.hs --- a/src/Lentil/Parse/Run.hs +++ b/src/Lentil/Parse/Run.hs @@ -7,7 +7,9 @@ -- Parsing functions interface ----------------------------------------------------------------------------- -{-# LANGUAGE FlexibleContexts, LambdaCase #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} module Lentil.Parse.Run where @@ -18,65 +20,150 @@ import Lentil.Parse.Syntaxes import Text.Megaparsec -import Pipes -import qualified Control.Monad as CM -import qualified System.Directory as D -import qualified Control.Exception as E -import qualified System.ProgressBar as PB -import qualified Data.Text as T -import qualified Data.Text.IO as TI -import qualified Data.Text.Lazy as TL - +import qualified Control.Exception as E +import qualified Control.DeepSeq as DS +import qualified Control.Monad as CM +import qualified Control.Monad.Reader as R +import qualified Control.Monad.Trans as T +import qualified Data.DList as D +import qualified Data.IORef as I +import qualified Data.Text as T +import qualified Data.Text.IO as TI +import qualified Data.Text.Lazy as TL +import qualified System.Directory as D +import qualified System.ProgressBar as PB ----------- -- TYPES -- ----------- -type FileNum = Int -- current file number -type TotNum = Int -- total file number +data RunEnv = RunEnv + { -- reader part + reAliases :: [Alias], -- for parsing purposes + reFWords :: [FlagWord], -- for parsing purposes + -- stateful part + reFiles :: I.IORef [FilePath], -- fnames to process + reIssues :: I.IORef (D.DList Issue), -- processed issues + reBar :: PB.ProgressBar () } -- progress bar ------------ --- PIPES -- ------------ +newtype Runner a = Runner { runRunner :: R.ReaderT RunEnv IO a } + deriving (Functor, Applicative, Monad, + T.MonadIO, R.MonadReader RunEnv) -issueFinder :: [Alias] -> [FlagWord] -> TotNum -> - Pipe (FilePath, FileNum) [Issue] IO () -issueFinder as fws tn = fpExist tn >-> - fp2par as >-> - fp2comm >-> - cms2iss + +issueFinder :: [Alias] -> [FlagWord] -> [FilePath] -> IO [Issue] +issueFinder as fws fps = + creaEnv >>= \e -> + let r = runRunner runnerFinder in + R.runReaderT r e where - -- comm2Issues accepts Comment, we need [Comment] - cms2iss = await >>= \(fp, cs) -> - let tra = zip (repeat fp) cs in - each tra >-> - comm2Issues fws + creaEnv :: IO RunEnv + creaEnv = + let bIO = initProgressBar (length fps) in + I.newIORef fps >>= \ifs -> + I.newIORef D.empty >>= \iis -> + R.liftIO bIO >>= \pb -> + return (RunEnv as fws + ifs iis pb) ------------ --- PIPES -- ------------ +runnerFinder :: Runner [Issue] +runnerFinder = looperino >> + D.toList <$> asksIO reIssues + where + looperino :: Runner () + looperino = + asksIO reFiles >>= \case + [] -> return () + _ -> processFile >> + looperino --- file exist check -fpExist :: TotNum -> Pipe (FilePath, FileNum) FilePath IO () -fpExist t = await >>= \(fp, k) -> - pbe k >> - liftIO (D.doesFileExist fp) >>= \fb -> - if fb == False - then liftIO (perr $ fp ++ " : no such file") - else yield fp +processFile :: Runner () +processFile = -- 1. does exist + fetchFile >>= \fp -> + doesFileExist fp >>= \bf -> + if not bf + then return () + else + + -- 2. execute parse (and store results) + parseFile fp >> + + -- 3. update counter and blit it + blitCounter + + +------------- +-- PARSING -- +------------- + +parseFile :: FilePath -> Runner () +parseFile fp = + -- 1. language parser finder + R.asks reAliases >>= \as -> + case langParserAlias as fp of + Nothing -> return () + Just p -> -- 2. parse comments + parseComments fp p >>= \cs -> + -- 3. parse issues (and write them) + mapM_ (parseIssues fp) cs + +parseComments :: FilePath -> StateParser () [CommentString] -> + Runner [Comment] +parseComments fp p = + T.liftIO (safeRead fp) >>= \t -> + runPar (comms2Tuple <$> p) fp () t + -- meglio di + -- comms2Tuple <$> runPar p fp () t + -- così evitiamo istanza deepseq per CommentString + +-- from a single comment +parseIssues :: FilePath -> (Row, String) -> Runner () +parseIssues fp (r, cs) = + -- parse + R.asks reFWords >>= \fws -> + runPar issPar fp fws cs >>= \dis -> + + -- write + let appd bd = D.append bd dis in + R.asks reIssues >>= \iis -> + T.liftIO (I.modifyIORef' iis appd) where - fi i = fromIntegral i - pbe k = CM.when (mod k 30 == 0 && t > 100) - (liftIO (() <$ pb k)) + issPar :: StateParser [FlagWord] (D.DList Issue) + issPar = D.fromList <$> (setRow r >> issues) - -- the bar itself - pb k = PB.newProgressBar - myBar - 2 - (PB.Progress (fi k) (fi t) ()) +-- generic parsing +runPar :: (Monoid o, DS.NFData o) => + StateParser s o -> FilePath -> s -> String -> Runner o +runPar p fp s i = + case runStateParser p s fp i of + Left l -> rperr (fp ++ " : parse error " ++ + errorBundlePretty l) >> + return mempty + Right r -> return (DS.deepseq r r) + +-- todo [refactor] Row should be carried on by issues, not be manually set! +setRow :: Row -> ParIssue () +setRow r = updateParserState + (\(State i o (PosState pix po (SourcePos n _ cx) tw lp)) -> + let l' = mkPos r in + State i o (PosState pix po (SourcePos n l' cx) tw lp)) + + +------------------ +-- PROGRESS BAR -- +------------------ + +blitCounter :: Runner () +blitCounter = R.asks reBar >>= \pb -> + T.liftIO (PB.incProgress pb 1) + +-- t: total issues +initProgressBar :: Int -> IO (PB.ProgressBar ()) +initProgressBar t = PB.newProgressBar myBar 2 (PB.Progress 0 t ()) + where myBar = PB.defStyle { PB.styleDone = '*', PB.styleCurrent = '*', @@ -84,56 +171,34 @@ PB.styleWidth = PB.ConstantWidth 40, PB.stylePrefix = PB.msg barMes } - barMes = TL.pack $ show t ++ " source files" - --- pick appropriate parser (if exists) -fp2par :: [Alias] -> Pipe FilePath (FilePath, ParSource [Comment]) IO () -fp2par as = await >>= \fp -> - case langParserAlias as fp of - Nothing -> return () - Just p -> yield (fp, fmap comms2Tuple p) - --- Parse raw comments -fp2comm :: Pipe (FilePath, ParSource [Comment]) (FilePath, [Comment]) IO () -fp2comm = await >>= \(fp, p) -> - liftIO (safeRead fp) >>= \t -> - - (runParPipe p fp () t >-> - (await >>= \r -> - - yield (fp, r))) - -comm2Issues :: [FlagWord] -> Pipe (FilePath, Comment) [Issue] IO () -comm2Issues fws = await >>= \(fp, (r, i)) -> - runParPipe (setRow r >> issues) - fp fws i >> - comm2Issues fws -- needed or will pick just head issue + barMes = TL.pack $ show t ++ " source files" ----------------- -- ANCILLARIES -- ----------------- --- generic parsing -- +asksIO :: (RunEnv -> I.IORef a) -> Runner a +asksIO a = R.asks a >>= \ia -> + T.liftIO (I.readIORef ia) -runParPipe :: StateParser s o -> - FilePath -> s -> String -> - Pipe ip o IO () -runParPipe p fp s i = - case runStateParser p s fp i of - Left l -> liftIO (perr $ fp ++ " : parse error " ++ - errorBundlePretty l) - Right r -> yield r +fetchFile :: Runner FilePath +fetchFile = asksIO reFiles >>= \case + [] -> error "(assert) fetchFile called on empty filelist!" + (f:fs) -> R.asks reFiles >>= \ifs -> + T.liftIO (I.writeIORef ifs fs) >> + return f --- issue parsing -- +doesFileExist :: FilePath -> Runner Bool +doesFileExist fp = + T.liftIO (D.doesFileExist fp) >>= \fb -> + CM.when (not fb) + (rperr $ fp ++ " : no such file") >> + return fb --- todo [refactor] Row should be carried on by issues, not be manually set! -setRow :: Row -> ParIssue () -setRow r = updateParserState - (\(State i o (PosState pix po (SourcePos n _ cx) tw lp)) -> - let l' = mkPos r in - State i o (PosState pix po (SourcePos n l' cx) tw lp)) +rperr :: String -> Runner () +rperr s = T.liftIO $ perr s safeRead :: FilePath -> IO String safeRead fp = E.try (TI.readFile fp) >>= \case @@ -141,3 +206,4 @@ Left x -> perr (fp ++ " : " ++ show (x :: E.IOException) ++ " -- ignoring file") >> return "" + diff --git a/src/Lentil/Parse/Source.hs b/src/Lentil/Parse/Source.hs --- a/src/Lentil/Parse/Source.hs +++ b/src/Lentil/Parse/Source.hs @@ -16,9 +16,9 @@ import Text.Megaparsec import Text.Megaparsec.Char -import qualified Data.Char as C -import qualified Data.Maybe as M -import qualified Data.List as L +import qualified Data.Char as C +import qualified Data.Maybe as M +import qualified Data.List as L ----------- diff --git a/src/Lentil/Parse/Syntaxes.hs b/src/Lentil/Parse/Syntaxes.hs --- a/src/Lentil/Parse/Syntaxes.hs +++ b/src/Lentil/Parse/Syntaxes.hs @@ -27,6 +27,12 @@ -- next line, are valid C comments but not recognised by lentil -- as langParser, with alias added + +-- todo [u:1] [request] (Iustin Pop) export to markdown. +-- todo [u:1] [request] scanner for yesod templates +-- (hamlet/julius/casius) which are a bit difficult since they are +-- html/js/css + embedded Haskell. + langParserAlias :: [Alias] -> String -> MaybePar langParserAlias as fp = maybe (langParser fp) langParser (lookup ext as) where ext = map C.toLower (SF.takeExtension fp) diff --git a/src/Lentil/Types.hs b/src/Lentil/Types.hs --- a/src/Lentil/Types.hs +++ b/src/Lentil/Types.hs @@ -7,21 +7,29 @@ -- Types descriptions ----------------------------------------------------------------------------- +{-# LANGUAGE DeriveGeneric #-} + module Lentil.Types where -import qualified Data.List as L -import qualified Data.Char as C +import qualified Control.DeepSeq as DS +import qualified Data.List as L +import qualified Data.Char as C +import qualified GHC.Generics as G data Issue = Issue { iFile :: FilePath, iRow :: Row, - iDesc :: Maybe Description, + iDesc :: (Maybe Description), iTags :: [Tag] } - deriving (Eq, Show) + deriving (Eq, Show, G.Generic) +instance DS.NFData Issue + newtype Tag = Tag { tagString :: String } - deriving (Show, Eq, Ord) + deriving (Show, Eq, Ord, G.Generic) + +instance DS.NFData Tag type Description = String type Row = Int diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -32,7 +32,7 @@ short 'v' S.<> help "show version and copyright info" ) where - versionCopy = "\nlentil - frugal issue tracker, version 1.2.3.0\n\ + versionCopy = "\nlentil - frugal issue tracker, version 1.3.0.0\n\ \(C) 2015-2019 Francesco Ariis - http://www.ariis.it\n\ \released under the GNU General Public License v3\n" diff --git a/test/Lentil/Parse/RunSpec.hs b/test/Lentil/Parse/RunSpec.hs --- a/test/Lentil/Parse/RunSpec.hs +++ b/test/Lentil/Parse/RunSpec.hs @@ -1,22 +1,16 @@ module Lentil.Parse.RunSpec where import Test.Hspec -import Pipes import Lentil.Types import Lentil.Parse.Run -import qualified Pipes.Prelude as PP - import Prelude -- 7.8 hack -- Parsing tests fileParser :: [Alias] -> [FlagWord] -> FilePath -> IO [Issue] -fileParser as fws fp = fmap concat (PP.toListM myPipe) - where - myPipe = yield (fp, 1) >-> issLoop - issLoop = issueFinder as fws 1 >> issLoop +fileParser as fws fp = issueFinder as fws [fp] main :: IO ()