diff --git a/fixme-new/lib/Fixme/Run.hs b/fixme-new/lib/Fixme/Run.hs index 6f8c4ced..74630b30 100644 --- a/fixme-new/lib/Fixme/Run.hs +++ b/fixme-new/lib/Fixme/Run.hs @@ -749,24 +749,41 @@ runForms ss = for_ ss $ \s -> do stage <- gitListStage blobs <- for stage $ \case - Left (fn, _) -> pure (fn, liftIO $ LBS8.readFile fn) - Right (fn,hash) -> pure (fn, liftIO (withFixmeEnv env $ gitCatBlob hash)) + Left (fn, hash) -> pure (fn, hash, liftIO $ LBS8.readFile fn) + Right (fn,hash) -> pure (fn, hash, liftIO (withFixmeEnv env $ gitCatBlob hash)) - let fns = fmap fst blobs + let fns = fmap (view _1) blobs -- TODO: extract-metadata-from-git-blame -- subj - for_ blobs $ \(fn, readBlob) -> do + for_ blobs $ \(fn, bhash, readBlob) -> do + nno <- newTVarIO (mempty :: HashMap FixmeTitle Integer) lbs <- readBlob fxs <- scanBlob (Just fn) lbs >>= \e -> do for e $ \fx0 -> do + n <- atomically $ stateTVar nno (\m -> do + let what = HM.lookup (fixmeTitle fx0) m & fromMaybe 0 + (what, HM.insert (fixmeTitle fx0) (succ what) m) + ) let ls = fixmePlain fx0 meta <- getMetaDataFromGitBlame fn fx0 - -- let fxm = fromMaybe mempty $ HM.lookup fn meta + let tit = fixmeTitle fx0 & coerce @_ @Text + + -- FIXME: fix-this-copypaste + let ks = [qc|{fn}#{tit}:{n}|] :: Text + let ksh = hashObject @HbSync (serialise ks) & pretty & show & Text.pack & FixmeAttrVal + let kh = HM.singleton "fixme-key" ksh + let kv = HM.singleton "fixme-key-string" (FixmeAttrVal ks) <> kh + pure $ fixmeDerivedFields (fx0 <> mkFixmeFileName fn <> meta) - & set (field @"fixmePlain") ls + & set (field @"fixmePlain") ls + + & over (field @"fixmeAttr") + (HM.insert "blob" (fromString $ show $ pretty bhash)) + & over (field @"fixmeAttr") + (mappend (kh<>kv)) for_ fxs $ \fx -> do liftIO $ print (pretty fx) diff --git a/fixme-new/lib/Fixme/Types.hs b/fixme-new/lib/Fixme/Types.hs index 5f281c00..fd637c7f 100644 --- a/fixme-new/lib/Fixme/Types.hs +++ b/fixme-new/lib/Fixme/Types.hs @@ -7,7 +7,7 @@ module Fixme.Types import Fixme.Prelude hiding (align) import HBS2.Base58 -import DBPipe.SQLite +import DBPipe.SQLite hiding (field) import HBS2.Git.Local import Data.Config.Suckless @@ -30,6 +30,8 @@ import Data.List qualified as List import Data.Map qualified as Map import System.FilePath import Text.InterpolatedString.Perl6 (qc) +import Data.Generics.Product.Fields (field) +import Lens.Micro.Platform -- FIXME: move-to-suckless-conf deriving stock instance Ord (Syntax C) @@ -134,7 +136,7 @@ newtype FixmeTag = FixmeTag { fromFixmeTag :: Text } deriving stock (Data,Generic) newtype FixmeTitle = FixmeTitle { fromFixmeTitle :: Text } - deriving newtype (Eq,Ord,Show,IsString,Semigroup,Monoid,ToField,FromField) + deriving newtype (Eq,Ord,Show,IsString,Semigroup,Monoid,ToField,FromField,Hashable) deriving stock (Data,Generic) newtype FixmePlainLine = FixmePlainLine { fromFixmeText :: Text } @@ -611,7 +613,7 @@ fixmeAttrNonEmpty a b = case (coerce a :: Text, coerce b :: Text) of (_,_) -> b fixmeDerivedFields :: Fixme -> Fixme -fixmeDerivedFields fx = fx <> fxCo <> tag <> fxLno +fixmeDerivedFields fx = fx <> fxCo <> tag <> fxLno <> fxMisc where email = HM.lookup "commiter-email" (fixmeAttr fx) & maybe mempty (\x -> " <" <> x <> ">") @@ -628,6 +630,10 @@ fixmeDerivedFields fx = fx <> fxCo <> tag <> fxLno fxCo = maybe mempty (\c -> mempty { fixmeAttr = HM.singleton "committer" c }) comitter + fxMisc = + fx & over (field @"fixmeAttr") + (HM.insert "fixme-title" (FixmeAttrVal (coerce (fixmeTitle fx)))) + mkFixmeFileName :: FilePath -> Fixme mkFixmeFileName fp = mempty { fixmeAttr = HM.singleton "file" (FixmeAttrVal (fromString fp)) }