From 20360a21805437f508f75268da1c9e50599cedee Mon Sep 17 00:00:00 2001
From: Dmitry Zuikov <dzuikov@gmail.com>
Date: Fri, 14 Jun 2024 12:06:15 +0300
Subject: [PATCH] wip

---
 .gitignore                   |  1 +
 fixme-new/lib/Fixme/Run.hs   | 30 +++++++++++++++++++++++++-----
 fixme-new/lib/Fixme/Types.hs |  7 +++++++
 3 files changed, 33 insertions(+), 5 deletions(-)

diff --git a/.gitignore b/.gitignore
index 48ee1944..bcd3f9ac 100644
--- a/.gitignore
+++ b/.gitignore
@@ -12,3 +12,4 @@ cabal.project.local
 .backup/
 .hbs2-git/
 bin/
+.fixme-new/current-stage.log
diff --git a/fixme-new/lib/Fixme/Run.hs b/fixme-new/lib/Fixme/Run.hs
index 754852bf..072c1cc3 100644
--- a/fixme-new/lib/Fixme/Run.hs
+++ b/fixme-new/lib/Fixme/Run.hs
@@ -747,11 +747,14 @@ runForms ss = for_  ss $ \s -> do
       fxm <-  gitExtractFileMetaData fs <&> HM.toList
       liftIO $ print $ vcat (fmap (pretty.snd) fxm)
 
-    ListVal [SymbolVal "builtin:extract-from-stage"] -> do
+    ListVal (SymbolVal "builtin:git:extract-from-stage" : opts) -> do
       env <- ask
-      stage <- gitListStage
+      gitStage <- gitListStage
 
-      blobs  <- for stage $ \case
+      let dry = or [ True | StringLike "dry" <- opts ]
+      let verbose = or [ True | StringLike "verbose" <- opts ]
+
+      blobs  <- for gitStage $ \case
           Left (fn, hash) -> pure (fn, hash, liftIO $ LBS8.readFile fn)
           Right (fn,hash) -> pure (fn, hash, liftIO (withFixmeEnv env $ gitCatBlob hash))
 
@@ -760,6 +763,10 @@ runForms ss = for_  ss $ \s -> do
       -- TODO: extract-metadata-from-git-blame
       --   subj
 
+      stageFile <- localConfigDir <&> (</> "current-stage.log")
+
+      fmeStage <- compactStorageOpen mempty stageFile
+
       for_ blobs $ \(fn, bhash, readBlob) -> do
         nno <- newTVarIO (mempty :: HashMap FixmeTitle Integer)
         lbs <- readBlob
@@ -788,8 +795,21 @@ runForms ss = for_  ss $ \s -> do
                              & over (field @"fixmeAttr")
                                     (mappend (kh<>kv))
 
-        for_ fxs $ \fx -> do
-          liftIO $ print (pretty fx)
+        unless dry do
+          for_ fxs $ \fx -> void $ runMaybeT do
+            e <- getEpoch
+            let what = Added e fx
+            let k = mkKey (FromFixmeKey fx)
+            get fmeStage k >>= guard . isNothing
+            put fmeStage k (LBS.toStrict $ serialise what)
+
+            when verbose do
+              liftIO $ print (pretty fx)
+
+      when dry do
+        warn $ red "FUCKING DRY!"
+
+      compactStorageClose fmeStage
 
     ListVal [SymbolVal "trace"] -> do
       setLogging @TRACE (logPrefix "[trace] " . toStderr)
diff --git a/fixme-new/lib/Fixme/Types.hs b/fixme-new/lib/Fixme/Types.hs
index fd637c7f..571a672b 100644
--- a/fixme-new/lib/Fixme/Types.hs
+++ b/fixme-new/lib/Fixme/Types.hs
@@ -220,6 +220,8 @@ data SimpleTemplate = forall c . (IsContext c, Data (Context c), Data c) => Simp
 class HasSequence w where
   getSequence :: w -> Word64
 
+newtype FromFixmeKey a = FromFixmeKey a
+
 data CompactAction =
     Deleted  Word64 HashRef
   | Modified Word64 HashRef FixmeAttrName FixmeAttrVal
@@ -234,6 +236,11 @@ instance MkKey CompactAction where
   mkKey (Modified _ h _ _) = "M" <> LBS.toStrict (serialise h)
   mkKey (Added _ fixme) = "A" <> coerce (hashObject @HbSync $ serialise fixme)
 
+instance MkKey (FromFixmeKey Fixme) where
+  mkKey (FromFixmeKey fx@Fixme{..}) =
+    maybe k2  (mappend "A" . LBS.toStrict . serialise) (HM.lookup "fixme-key" fixmeAttr)
+    where k2 = mappend "A" $ serialise fx & LBS.toStrict
+
 instance Pretty CompactAction where
   pretty = \case
     Deleted s r      -> pretty $ mklist @C [ mksym "deleted", mkint s, mkstr r  ]