wip

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

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 ()
+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
+            & (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)
 
 

fixme-new/lib/Fixme/Types.hs

@@ -67,6 +67,8 @@ type FixmePerks m = ( MonadUnliftIO m
 data FixmeEnv =
   FixmeEnv
   { 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