voidlizard
/
hbs2
mirror of https://github.com/voidlizard/hbs2
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

wip

This commit is contained in:
Dmitry Zuikov 2024-06-14 08:36:53 +03:00
parent 43d81e4892
commit ea4666e8f1
2 changed files with 32 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
fixme-new/lib/Fixme/Run.hs
View File

@ -749,24 +749,41 @@ runForms ss = for_ ss $ \s -> do
stage <- gitListStage stage <- gitListStage
blobs <- for stage $ \case blobs <- for stage $ \case
Left (fn, _) -> pure (fn, liftIO $ LBS8.readFile fn) Left (fn, hash) -> pure (fn, hash, liftIO $ LBS8.readFile fn)
Right (fn,hash) -> pure (fn, liftIO (withFixmeEnv env $ gitCatBlob hash)) 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 -- TODO: extract-metadata-from-git-blame
-- subj -- subj
for_ blobs $ \(fn, readBlob) -> do for_ blobs $ \(fn, bhash, readBlob) -> do
nno <- newTVarIO (mempty :: HashMap FixmeTitle Integer)
lbs <- readBlob lbs <- readBlob
fxs <- scanBlob (Just fn) lbs fxs <- scanBlob (Just fn) lbs
>>= \e -> do >>= \e -> do
for e $ \fx0 -> 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 let ls = fixmePlain fx0
meta <- getMetaDataFromGitBlame fn 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) 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 for_ fxs $ \fx -> do
liftIO $ print (pretty fx) liftIO $ print (pretty fx)

12
fixme-new/lib/Fixme/Types.hs
View File

@ -7,7 +7,7 @@ module Fixme.Types
import Fixme.Prelude hiding (align) import Fixme.Prelude hiding (align)
import HBS2.Base58 import HBS2.Base58
import DBPipe.SQLite import DBPipe.SQLite hiding (field)
import HBS2.Git.Local import HBS2.Git.Local
import Data.Config.Suckless import Data.Config.Suckless
@ -30,6 +30,8 @@ import Data.List qualified as List
import Data.Map qualified as Map import Data.Map qualified as Map
import System.FilePath import System.FilePath
import Text.InterpolatedString.Perl6 (qc) import Text.InterpolatedString.Perl6 (qc)
import Data.Generics.Product.Fields (field)
import Lens.Micro.Platform
-- FIXME: move-to-suckless-conf -- FIXME: move-to-suckless-conf
deriving stock instance Ord (Syntax C) deriving stock instance Ord (Syntax C)
@ -134,7 +136,7 @@ newtype FixmeTag = FixmeTag { fromFixmeTag :: Text }
deriving stock (Data,Generic) deriving stock (Data,Generic)
newtype FixmeTitle = FixmeTitle { fromFixmeTitle :: Text } 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) deriving stock (Data,Generic)
newtype FixmePlainLine = FixmePlainLine { fromFixmeText :: Text } newtype FixmePlainLine = FixmePlainLine { fromFixmeText :: Text }
@ -611,7 +613,7 @@ fixmeAttrNonEmpty a b = case (coerce a :: Text, coerce b :: Text) of
(_,_) -> b (_,_) -> b
fixmeDerivedFields :: Fixme -> Fixme fixmeDerivedFields :: Fixme -> Fixme
fixmeDerivedFields fx = fx <> fxCo <> tag <> fxLno fixmeDerivedFields fx = fx <> fxCo <> tag <> fxLno <> fxMisc
where where
email = HM.lookup "commiter-email" (fixmeAttr fx) email = HM.lookup "commiter-email" (fixmeAttr fx)
& maybe mempty (\x -> " <" <> x <> ">") & maybe mempty (\x -> " <" <> x <> ">")
@ -628,6 +630,10 @@ fixmeDerivedFields fx = fx <> fxCo <> tag <> fxLno
fxCo = fxCo =
maybe mempty (\c -> mempty { fixmeAttr = HM.singleton "committer" c }) comitter 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 :: FilePath -> Fixme
mkFixmeFileName fp = mkFixmeFileName fp =
mempty { fixmeAttr = HM.singleton "file" (FixmeAttrVal (fromString fp)) } mempty { fixmeAttr = HM.singleton "file" (FixmeAttrVal (fromString fp)) }