From ad647de8323dcdf10ae3275e172262fca3039565 Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Thu, 9 May 2024 10:29:09 +0300 Subject: [PATCH] wip --- fixme-new/lib/Fixme/Prelude.hs | 3 +- fixme-new/lib/Fixme/Run.hs | 82 +++++++++++++++++++++++++++------- fixme-new/lib/Fixme/Types.hs | 11 ++++- 3 files changed, 77 insertions(+), 19 deletions(-) diff --git a/fixme-new/lib/Fixme/Prelude.hs b/fixme-new/lib/Fixme/Prelude.hs index ce95d562..78e12eaa 100644 --- a/fixme-new/lib/Fixme/Prelude.hs +++ b/fixme-new/lib/Fixme/Prelude.hs @@ -12,4 +12,5 @@ import Codec.Serialise (Serialise(..)) import Data.Functor as All import Data.Function as All import UnliftIO as All - +import System.FilePattern as All +import Control.Monad.Reader as All diff --git a/fixme-new/lib/Fixme/Run.hs b/fixme-new/lib/Fixme/Run.hs index 35437d24..db64951f 100644 --- a/fixme-new/lib/Fixme/Run.hs +++ b/fixme-new/lib/Fixme/Run.hs @@ -1,4 +1,5 @@ {-# Language PatternSynonyms #-} +{-# Language ViewPatterns #-} module Fixme.Run where import Prelude hiding (init) @@ -16,8 +17,11 @@ import Data.ByteString.Lazy.Char8 qualified as LBS8 import Data.Either import System.Environment import Data.Maybe +import Data.HashSet qualified as HS +import Data.HashMap.Strict qualified as HM +import Data.Text qualified as Text import Text.InterpolatedString.Perl6 (qc) -import Lens.Micro.Platform + {- HLINT ignore "Functor law" -} @@ -27,6 +31,15 @@ pattern Init <- ListVal [SymbolVal "init"] pattern ScanGitLocal :: forall {c}. Syntax c pattern ScanGitLocal <- ListVal [SymbolVal "scan-git"] +pattern FixmeFiles :: forall {c} . [FilePattern] -> Syntax c +pattern FixmeFiles e <- ListVal (SymbolVal "fixme-files" : (fileMasks -> e)) + +pattern FixmeGitScanFilterDays :: forall {c}. Integer -> Syntax c +pattern FixmeGitScanFilterDays d <- ListVal [ SymbolVal "fixme-git-scan-filter-days", LitIntVal d ] + +fileMasks :: [Syntax c] -> [FilePattern] +fileMasks what = [ show (pretty s) | s <- what ] + binName :: FixmePerks m => m FilePath binName = liftIO getProgName @@ -39,6 +52,14 @@ localConfigDir = do localConfig:: FixmePerks m => m FilePath localConfig = localConfigDir <&> ( "config") + +readConfig :: FixmePerks m => FixmeM m [Syntax C] +readConfig = do + localConfig + >>= liftIO . readFile + <&> parseTop + <&> fromRight mempty + init :: FixmePerks m => FixmeM m () init = do lo <- localConfigDir @@ -61,17 +82,26 @@ init = do , "git add" <+> pretty (lo0 "config") ] -listCommits :: FixmePerks m => m [GitHash] +listCommits :: FixmePerks m => FixmeM m [GitHash] listCommits = do let gd = "" + + days <- asks fixmeEnvGitScanDays + >>= readTVarIO + <&> fmap ( \x -> "--since" <+> squotes (pretty x <+> "days ago")) + <&> fromMaybe mempty + <&> show + + let cmd = [qc|git log --all --format="%H" {days}|] + -- FIXME: git-dir - gitRunCommand [qc|git rev-list --all|] + gitRunCommand cmd <&> fromRight mempty <&> mapMaybe (headMay . LBS8.words) . LBS8.lines <&> mapMaybe (fromStringMay @GitHash . LBS8.unpack) -listBlobs :: FixmePerks m => GitHash -> m [(FilePath, GitHash)] +listBlobs :: FixmePerks m => GitHash -> m [(FilePath,GitHash)] listBlobs co = do -- FIXME: git-dir gitRunCommand [qc|git ls-tree -r -l -t {pretty co}|] @@ -79,16 +109,25 @@ listBlobs co = do <&> fmap LBS8.words . LBS8.lines <&> mapMaybe (\case - [a,_,h,_,fn] -> (LBS8.unpack fn,) <$> fromStringMay @GitHash (LBS8.unpack h) + [a,"blob",h,_,fn] -> (LBS8.unpack fn,) <$> fromStringMay @GitHash (LBS8.unpack h) _ -> Nothing) +filterBlobs :: FixmePerks m + => [(FilePath,GitHash)] + -> FixmeM m [(FilePath,GitHash)] -scanGitLocal :: FixmePerks m => Maybe FilePath -> m () -scanGitLocal p = do +filterBlobs xs = do + pat <- asks fixmeEnvFileMask >>= readTVarIO <&> fmap (True,) + let src = [ ((f,h),f) | (f,h) <- xs ] + let r = [(h,f) | (_,(f,h),_) <- matchMany pat src] & HM.fromList & HM.toList + pure $ [ (b,a) | (a,b) <- r ] + +scanGitLocal :: FixmePerks m => Maybe FilePath -> FixmeM m () +scanGitLocal p = do debug $ yellow "scan for fixmies, wtf?" co <- listCommits for_ co $ \c -> do - blobs <- listBlobs c + blobs <- listBlobs c >>= filterBlobs debug $ vcat (fmap pretty blobs) help :: FixmePerks m => m () @@ -98,17 +137,28 @@ help = do run :: FixmePerks m => [String] -> FixmeM m () run what = do + sc <- readConfig + let s0 = parseTop (unwords what) - & fromRight mempty + & fromRight mempty + & (sc <>) - debug $ pretty s0 + for_ s0 $ \s -> do - case s0 of - [Init] -> init + case s of - [ScanGitLocal] -> scanGitLocal Nothing - - - _ -> help + FixmeFiles xs -> do + t <- asks fixmeEnvFileMask + atomically (modifyTVar t (<> xs)) + + FixmeGitScanFilterDays d -> do + t <- asks fixmeEnvGitScanDays + atomically (writeTVar t (Just d)) + + Init -> init + + ScanGitLocal -> scanGitLocal Nothing + + w -> err (pretty w) diff --git a/fixme-new/lib/Fixme/Types.hs b/fixme-new/lib/Fixme/Types.hs index b9a467b9..df3dabeb 100644 --- a/fixme-new/lib/Fixme/Types.hs +++ b/fixme-new/lib/Fixme/Types.hs @@ -66,7 +66,9 @@ type FixmePerks m = ( MonadUnliftIO m data FixmeEnv = FixmeEnv - { fixmeEnvGitDir :: Maybe FilePath + { fixmeEnvGitDir :: Maybe FilePath + , fixmeEnvFileMask :: TVar [FilePattern] + , fixmeEnvGitScanDays :: TVar (Maybe Integer) } newtype FixmeM m a = FixmeM { fromFixmeM :: ReaderT FixmeEnv m a } @@ -79,7 +81,12 @@ newtype FixmeM m a = FixmeM { fromFixmeM :: ReaderT FixmeEnv m a } ) runFixmeCLI :: FixmePerks m => FixmeM m a -> m a -runFixmeCLI m = runReaderT ( setupLogger >> fromFixmeM m ) (FixmeEnv Nothing) +runFixmeCLI m = do + env <- FixmeEnv Nothing + <$> newTVarIO mempty + <*> newTVarIO Nothing + + runReaderT ( setupLogger >> fromFixmeM m ) env `finally` flushLoggers where setupLogger = do