lentil 1.2.3.0 → 1.3.0.0
raw patch · 12 files changed
+204/−123 lines, 12 filesdep +deepseqdep +dlistdep −pipes
Dependencies added: deepseq, dlist
Dependencies removed: pipes
Files
- changes.txt +7/−0
- issues.txt +9/−3
- lentil.cabal +5/−3
- src/Lentil/Export.hs +6/−0
- src/Lentil/File.hs +2/−10
- src/Lentil/Helpers.hs +0/−6
- src/Lentil/Parse/Run.hs +151/−85
- src/Lentil/Parse/Source.hs +3/−3
- src/Lentil/Parse/Syntaxes.hs +6/−0
- src/Lentil/Types.hs +13/−5
- src/Main.hs +1/−1
- test/Lentil/Parse/RunSpec.hs +1/−7
changes.txt view
@@ -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 -------
issues.txt view
@@ -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
lentil.cabal view
@@ -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.*,
src/Lentil/Export.hs view
@@ -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 --
src/Lentil/File.hs view
@@ -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]
src/Lentil/Helpers.hs view
@@ -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 -- -------------
src/Lentil/Parse/Run.hs view
@@ -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 ""+
src/Lentil/Parse/Source.hs view
@@ -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 -----------
src/Lentil/Parse/Syntaxes.hs view
@@ -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)
src/Lentil/Types.hs view
@@ -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
src/Main.hs view
@@ -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"
test/Lentil/Parse/RunSpec.hs view
@@ -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 ()