diff --git a/fixme-new/lib/Fixme/Run.hs b/fixme-new/lib/Fixme/Run.hs index 4a351841..ee91e476 100644 --- a/fixme-new/lib/Fixme/Run.hs +++ b/fixme-new/lib/Fixme/Run.hs @@ -3,7 +3,7 @@ module Fixme.Run where import Prelude hiding (init) -import Fixme.Prelude +import Fixme.Prelude hiding (indent) import Fixme.Types import Fixme.Scan.Git as Git @@ -15,15 +15,18 @@ import Data.Config.Suckless import Data.Text.Fuzzy.Tokenize import Data.ByteString.Lazy.Char8 qualified as LBS8 +import Data.ByteString.Lazy (ByteString) 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 Data.Text.Encoding qualified as Text import Text.InterpolatedString.Perl6 (qc) import Data.Coerce import Control.Monad.Identity +import Lens.Micro.Platform import Streaming.Prelude qualified as S @@ -48,6 +51,11 @@ pattern FixmePrefix s <- ListVal [SymbolVal "fixme-prefix", fixmePrefix -> Just pattern FixmeGitScanFilterDays :: forall {c}. Integer -> Syntax c pattern FixmeGitScanFilterDays d <- ListVal [ SymbolVal "fixme-git-scan-filter-days", LitIntVal d ] +pattern StringLike :: forall {c} . String -> Syntax c +pattern StringLike e <- (stringLike -> Just e) + + + data ScanGitArgs = PrintBlobs deriving stock (Eq,Ord,Show,Data,Generic) @@ -55,6 +63,12 @@ data ScanGitArgs = scanGitArgs :: [Syntax c] -> [ScanGitArgs] scanGitArgs syn = [ PrintBlobs | SymbolVal "print-blobs" <- syn ] +stringLike :: Syntax c -> Maybe String +stringLike = \case + LitStrVal s -> Just $ Text.unpack s + SymbolVal (Id s) -> Just $ Text.unpack s + _ -> Nothing + fileMasks :: [Syntax c] -> [FilePattern] fileMasks what = [ show (pretty s) | s <- what ] @@ -151,14 +165,29 @@ scanGitLocal args p = do co <- listCommits blobs <- mconcat <$> for co (\c -> do + debug $ "commit" <+> pretty c listBlobs c >>= filterBlobs ) when (PrintBlobs `elem` args) do for_ blobs $ \(fp,h) -> do liftIO $ print $ pretty h <+> pretty fp + +exractFixme :: FixmePerks m => ByteString -> m [Fixme] +exractFixme bs = do + + let ls = LBS8.lines bs + + pure mempty + + +readUtf8 :: ByteString -> Text +readUtf8 bs = LBS8.toStrict bs & Text.decodeUtf8 + + readFixmeStdin :: FixmePerks m => FixmeM m () readFixmeStdin = do + what <- liftIO LBS8.getContents <&> LBS8.lines pure () printEnv :: FixmePerks m => FixmeM m () @@ -167,6 +196,11 @@ printEnv = do masks <- asks fixmeEnvFileMask >>= readTVarIO tags <- asks fixmeEnvTags >>= readTVarIO days <- asks fixmeEnvGitScanDays >>= readTVarIO + comments1 <- asks fixmeEnvDefComments >>= readTVarIO <&> HS.toList + + comments2 <- asks fixmeEnvFileComments >>= readTVarIO + <&> HM.toList + <&> fmap (over _2 HS.toList) for_ tags $ \m -> do liftIO $ print $ "fixme-prefix" <+> pretty m @@ -177,6 +211,15 @@ printEnv = do for_ days $ \d -> do liftIO $ print $ "fixme-git-scan-filter-days" <+> pretty d + for_ comments1 $ \d -> do + liftIO $ print $ "fixme-comments" <+> dquotes (pretty d) + + for_ comments2 $ \(ft, comm') -> do + for_ comm' $ \comm -> do + liftIO $ print $ "fixme-file-comments" + <+> dquotes (pretty ft) <+> dquotes (pretty comm) + + help :: FixmePerks m => m () help = do notice "this is help message" @@ -219,6 +262,11 @@ run what = do t <- asks fixmeEnvGitScanDays atomically (writeTVar t (Just d)) + ListVal [SymbolVal "fixme-file-comments", StringLike ft, StringLike b] -> do + let co = Text.pack b & HS.singleton + t <- asks fixmeEnvFileComments + atomically (modifyTVar t (HM.insertWith (<>) ft co)) + Init -> init ScanGitLocal args -> scanGitLocal args Nothing diff --git a/fixme-new/lib/Fixme/Types.hs b/fixme-new/lib/Fixme/Types.hs index afcf71f6..cae08751 100644 --- a/fixme-new/lib/Fixme/Types.hs +++ b/fixme-new/lib/Fixme/Types.hs @@ -3,9 +3,14 @@ module Fixme.Types where import Fixme.Prelude import Data.HashMap.Strict (HashMap) +import Data.HashMap.Strict qualified as HM import Data.HashSet (HashSet) +import Data.HashSet qualified as HS import Data.Word (Word64) +import Data.Maybe import Data.Coerce +import System.FilePath + data GitLocation = GitLocation @@ -65,12 +70,25 @@ type FixmePerks m = ( MonadUnliftIO m data FixmeEnv = FixmeEnv - { fixmeEnvGitDir :: Maybe FilePath - , fixmeEnvFileMask :: TVar [FilePattern] - , fixmeEnvTags :: TVar (HashSet FixmeTag) - , fixmeEnvGitScanDays :: TVar (Maybe Integer) + { fixmeEnvGitDir :: Maybe FilePath + , fixmeEnvFileMask :: TVar [FilePattern] + , fixmeEnvTags :: TVar (HashSet FixmeTag) + , fixmeEnvDefComments :: TVar (HashSet Text) + , fixmeEnvFileComments :: TVar (HashMap FilePath (HashSet Text)) + , fixmeEnvGitScanDays :: TVar (Maybe Integer) } + +fixmeGetCommentsFor :: FixmePerks m => FilePath -> FixmeM m [Text] +fixmeGetCommentsFor fp = do + cof <- asks fixmeEnvFileComments >>= readTVarIO + def <- asks fixmeEnvDefComments >>= readTVarIO + + let r = maybe mempty HS.toList (HM.lookup (commentKey fp) cof) + <> HS.toList def + + pure r + newtype FixmeM m a = FixmeM { fromFixmeM :: ReaderT FixmeEnv m a } deriving newtype ( Applicative , Functor @@ -85,6 +103,8 @@ runFixmeCLI m = do env <- FixmeEnv Nothing <$> newTVarIO mempty <*> newTVarIO mempty + <*> newTVarIO mempty + <*> newTVarIO defCommentMap <*> newTVarIO Nothing runReaderT ( setupLogger >> fromFixmeM m ) env @@ -119,3 +139,26 @@ instance Pretty FixmeTitle where instance Pretty FixmeTag where pretty = pretty . coerce @_ @Text + + +defCommentMap :: HashMap FilePath (HashSet Text) +defCommentMap = HM.fromList + [ comment ".cabal" ["--"] + , comment ".hs" ["--"] + , comment ".c" ["//"] + , comment ".h" ["//"] + , comment ".cc" ["//"] + , comment ".cpp" ["//"] + , comment ".cxx" ["//"] + , comment "Makefile" ["#"] + ] + where + comment a b = (a, HS.fromList b) + +commentKey :: FilePath -> FilePath +commentKey fp = + case takeExtension fp of + "" -> takeFileName fp + xs -> xs + +