From d8ae2a079e934d8c893228c02f1e28fc129f4440 Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Thu, 9 May 2024 11:39:55 +0300 Subject: [PATCH] wip --- fixme-new/lib/Fixme/Run.hs | 99 +++++++++++++++++++++++++++++++----- fixme-new/lib/Fixme/Types.hs | 16 ++++-- 2 files changed, 98 insertions(+), 17 deletions(-) diff --git a/fixme-new/lib/Fixme/Run.hs b/fixme-new/lib/Fixme/Run.hs index db64951f..4a351841 100644 --- a/fixme-new/lib/Fixme/Run.hs +++ b/fixme-new/lib/Fixme/Run.hs @@ -12,6 +12,7 @@ import HBS2.Git.Local.CLI import HBS2.System.Dir import Data.Config.Suckless +import Data.Text.Fuzzy.Tokenize import Data.ByteString.Lazy.Char8 qualified as LBS8 import Data.Either @@ -21,25 +22,47 @@ 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 Data.Coerce +import Control.Monad.Identity +import Streaming.Prelude qualified as S {- HLINT ignore "Functor law" -} pattern Init :: forall {c}. Syntax c pattern Init <- ListVal [SymbolVal "init"] -pattern ScanGitLocal :: forall {c}. Syntax c -pattern ScanGitLocal <- ListVal [SymbolVal "scan-git"] +pattern ScanGitLocal :: forall {c}. [ScanGitArgs] -> Syntax c +pattern ScanGitLocal e <- ListVal (SymbolVal "scan-git" : (scanGitArgs -> e)) + +pattern ReadFixmeStdin :: forall {c}. Syntax c +pattern ReadFixmeStdin <- ListVal [SymbolVal "read-fixme-stdin"] pattern FixmeFiles :: forall {c} . [FilePattern] -> Syntax c pattern FixmeFiles e <- ListVal (SymbolVal "fixme-files" : (fileMasks -> e)) + +pattern FixmePrefix :: forall {c} . FixmeTag -> Syntax c +pattern FixmePrefix s <- ListVal [SymbolVal "fixme-prefix", fixmePrefix -> Just s] + pattern FixmeGitScanFilterDays :: forall {c}. Integer -> Syntax c pattern FixmeGitScanFilterDays d <- ListVal [ SymbolVal "fixme-git-scan-filter-days", LitIntVal d ] +data ScanGitArgs = + PrintBlobs + deriving stock (Eq,Ord,Show,Data,Generic) + +scanGitArgs :: [Syntax c] -> [ScanGitArgs] +scanGitArgs syn = [ PrintBlobs | SymbolVal "print-blobs" <- syn ] + fileMasks :: [Syntax c] -> [FilePattern] fileMasks what = [ show (pretty s) | s <- what ] +fixmePrefix :: Syntax c -> Maybe FixmeTag +fixmePrefix = \case + SymbolVal s -> Just (FixmeTag (coerce s)) + _ -> Nothing + binName :: FixmePerks m => m FilePath binName = liftIO getProgName @@ -122,28 +145,65 @@ filterBlobs xs = do 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 +scanGitLocal :: FixmePerks m => [ScanGitArgs] -> Maybe FilePath -> FixmeM m () +scanGitLocal args p = do debug $ yellow "scan for fixmies, wtf?" co <- listCommits - for_ co $ \c -> do - blobs <- listBlobs c >>= filterBlobs - debug $ vcat (fmap pretty blobs) + + blobs <- mconcat <$> for co (\c -> do + listBlobs c >>= filterBlobs ) + + when (PrintBlobs `elem` args) do + for_ blobs $ \(fp,h) -> do + liftIO $ print $ pretty h <+> pretty fp + +readFixmeStdin :: FixmePerks m => FixmeM m () +readFixmeStdin = do + pure () + +printEnv :: FixmePerks m => FixmeM m () +printEnv = do + g <- asks fixmeEnvGitDir + masks <- asks fixmeEnvFileMask >>= readTVarIO + tags <- asks fixmeEnvTags >>= readTVarIO + days <- asks fixmeEnvGitScanDays >>= readTVarIO + + for_ tags $ \m -> do + liftIO $ print $ "fixme-prefix" <+> pretty m + + for_ masks $ \m -> do + liftIO $ print $ "fixme-files" <+> dquotes (pretty m) + + for_ days $ \d -> do + liftIO $ print $ "fixme-git-scan-filter-days" <+> pretty d help :: FixmePerks m => m () help = do notice "this is help message" + +splitForms :: [String] -> [[String]] +splitForms s0 = runIdentity $ S.toList_ (go mempty s0) + where + go acc ( "then" : rest ) = emit acc >> go mempty rest + go acc ( x : rest ) = go ( x : acc ) rest + go acc [] = emit acc + + emit = S.yield . reverse + run :: FixmePerks m => [String] -> FixmeM m () run what = do sc <- readConfig - let s0 = parseTop (unwords what) - & fromRight mempty - & (sc <>) + let s0 = fmap (parseTop . unwords) (splitForms what) + & rights + & mconcat - for_ s0 $ \s -> do + + for_ (sc <> s0) $ \s -> do + + debug $ pretty s case s of @@ -151,13 +211,28 @@ run what = do t <- asks fixmeEnvFileMask atomically (modifyTVar t (<> xs)) + FixmePrefix tag -> do + t <- asks fixmeEnvTags + atomically (modifyTVar t (HS.insert tag)) + FixmeGitScanFilterDays d -> do t <- asks fixmeEnvGitScanDays atomically (writeTVar t (Just d)) Init -> init - ScanGitLocal -> scanGitLocal Nothing + ScanGitLocal args -> scanGitLocal args Nothing + + ReadFixmeStdin -> readFixmeStdin + + ListVal [SymbolVal "print-env"] -> do + printEnv + + ListVal [SymbolVal "no-debug"] -> do + setLoggingOff @DEBUG + + ListVal [SymbolVal "debug"] -> do + setLogging @DEBUG $ toStderr . logPrefix "[debug] " w -> err (pretty w) diff --git a/fixme-new/lib/Fixme/Types.hs b/fixme-new/lib/Fixme/Types.hs index df3dabeb..afcf71f6 100644 --- a/fixme-new/lib/Fixme/Types.hs +++ b/fixme-new/lib/Fixme/Types.hs @@ -2,11 +2,10 @@ module Fixme.Types where import Fixme.Prelude -import HBS2.System.Logger.Simple.ANSI - import Data.HashMap.Strict (HashMap) +import Data.HashSet (HashSet) import Data.Word (Word64) -import Control.Monad.Reader +import Data.Coerce data GitLocation = GitLocation @@ -21,7 +20,7 @@ data FixmeSource = deriving stock (Show,Data,Generic) newtype FixmeTag = FixmeTag { fromFixmeTag :: Text } - deriving newtype (Eq,Ord,Show,IsString) + deriving newtype (Eq,Ord,Show,IsString,Hashable) deriving stock (Data,Generic) newtype FixmeTitle = FixmeTitle { fromFixmeTitle :: Text } @@ -68,6 +67,7 @@ data FixmeEnv = FixmeEnv { fixmeEnvGitDir :: Maybe FilePath , fixmeEnvFileMask :: TVar [FilePattern] + , fixmeEnvTags :: TVar (HashSet FixmeTag) , fixmeEnvGitScanDays :: TVar (Maybe Integer) } @@ -84,13 +84,13 @@ runFixmeCLI :: FixmePerks m => FixmeM m a -> m a runFixmeCLI m = do env <- FixmeEnv Nothing <$> newTVarIO mempty + <*> newTVarIO mempty <*> newTVarIO Nothing runReaderT ( setupLogger >> fromFixmeM m ) env `finally` flushLoggers where setupLogger = do - setLogging @DEBUG $ toStderr . logPrefix "[debug] " setLogging @ERROR $ toStderr . logPrefix "[error] " setLogging @WARN $ toStderr . logPrefix "[warn] " setLogging @NOTICE $ toStdout . logPrefix "" @@ -113,3 +113,9 @@ instance Serialise FixmeTimestamp instance Serialise Fixme +instance Pretty FixmeTitle where + pretty = pretty . coerce @_ @Text + +instance Pretty FixmeTag where + pretty = pretty . coerce @_ @Text +