wip

.fixme-new/config

@@ -7,7 +7,7 @@
 fixme-prefix     FIXME:
 fixme-prefix     TODO:
 
-fixme-git-scan-filter-days 30
+fixme-git-scan-filter-days 1
 
 fixme-attribs assigned workflow
 
@@ -20,13 +20,14 @@ fixme-value-set cat bug feat refactor
 fixme-value-set scope mvp-0 mvp-1 backlog
 
 
-fixme-files **/*.txt docs/devlog.md
-fixme-files **/*.hs
+;fixme-files **/*.txt docs/devlog.md
+; fixme-files **/*.hs
+fixme-files **/Run.hs
 
 fixme-file-comments "*.scm" ";"
 
 fixme-comments ";" "--"
 
-update
+; update
 
 

fixme-new/fixme.cabal

@@ -73,6 +73,7 @@ common shared-properties
       , filepath
       , filepattern
       , generic-lens
+      , generic-deriving
       , interpolatedstring-perl6
       , memory
       , microlens-platform

fixme-new/lib/Fixme/Run.hs

@@ -34,6 +34,7 @@ import Data.Text qualified as Text
 import Data.Text.Encoding qualified as Text
 import Data.Text.Encoding (decodeUtf8With)
 import Data.Text.Encoding.Error (ignore)
+import Data.List qualified as List
 import Data.Word
 import Text.InterpolatedString.Perl6 (qc)
 import Data.Coerce
@@ -47,6 +48,11 @@ import System.IO qualified as IO
 
 import Streaming.Prelude qualified as S
 
+import Data.IntMap qualified as IntMap
+import Data.Map qualified as Map
+import Data.Map (Map)
+import Data.Set qualified as Set
+
 {- HLINT ignore "Functor law" -}
 
 pattern Init :: forall {c}. Syntax c
@@ -326,12 +332,13 @@ scanGitLocal args p =  do
         prefix <- liftIO (BS.hGetLine ssout) <&> BS.words
 
         case prefix of
-          [_, "blob", ssize] -> do
+          [bh, "blob", ssize] -> do
             let mslen = readMay @Int (BS.unpack ssize)
             len <- ContT $ maybe1 mslen (pure ())
             blob <- liftIO $ LBS8.hGet ssout len
             void $ liftIO $ BS.hGetLine ssout
 
+
             poor <- lift (Scan.scanBlob (Just fp) blob)
 
             rich <- withDB tempDb do
@@ -361,6 +368,7 @@ scanGitLocal args p =  do
             WHERE RelevantCommits.hash = ?
                       |]
 
+
                       what <- select @(FixmeAttrName,FixmeAttrVal) q (Only h)
                                 <&> HM.fromList
                                 <&> (<> HM.fromList [ ("blob",fromString $ show (pretty h))
@@ -368,14 +376,53 @@ scanGitLocal args p =  do
                                                     ])
 
                       for poor $ \f -> do
+                        let lno = maybe mempty ( HM.singleton "line"
+                                               . FixmeAttrVal
+                                               . Text.pack
+                                               . show
+                                               )
+                                       (fixmeStart f)
+
                         let ts = HM.lookup "commit-time" what
                                   <&> Text.unpack . coerce
                                   >>= readMay
                                   <&> FixmeTimestamp
 
-                        pure $ set (field @"fixmeTs") ts $ over (field @"fixmeAttr") (<> what) f
+                        pure $ set (field @"fixmeTs") ts $ over (field @"fixmeAttr") (<> (what <> lno)) f
 
-            let fixmies = rich
+
+            let fxpos1 = [ (fixmeTitle fx, [i :: Int])
+                         | (i,fx) <- zip [0..] rich
+                         -- , fixmeTitle fx /= mempty
+                         ] & Map.fromListWith (flip (<>))
+
+            let mt e = do
+                  let seed = [ (fst e, i) | i <- snd e ]
+                  flip fix (0,[],seed) $ \next (num,acc,rest) ->
+                    case rest of
+                      [] -> acc
+                      (x:xs) -> next (succ num, (x,num) : acc, xs)
+
+            let fxpos2 = [ mt e
+                         | e <- Map.toList fxpos1
+                         ] & mconcat
+                           & Map.fromList
+
+            debug $ red "fxpos1" <+> pretty h <> line <> pretty (Map.toList fxpos1)
+            debug $ red "fxpos2" <+> pretty h <> line <> pretty (Map.toList fxpos2)
+
+            fixmies <- for (zip [0..] rich) $ \(i,fx) -> do
+                         let title = fixmeTitle fx
+                         let kb = Map.lookup (title,i) fxpos2
+                         let ka = HM.lookup "file" (fixmeAttr fx)
+                         let kk = (,,) <$> ka <*> pure title <*> kb
+
+                         case kk of
+                          Nothing -> pure fx
+                          Just (a,b,c) -> do
+                            let ks = [qc|{show (pretty a)}#{show (pretty b)}:{show c}|] :: Text
+                            let kv = HM.singleton "fixme-key" (FixmeAttrVal ks)
+                            pure $ over (field @"fixmeAttr") (<> kv) fx
 
             when ( PrintFixme `elem` args ) do
               for_ fixmies $ \fixme -> do
@@ -558,6 +605,9 @@ run what = do
       ListVal [SymbolVal "builtin:evolve"] -> do
         evolve
 
+      ListVal [SymbolVal "builtin:cleanup-state"] -> do
+        cleanupDatabase
+
       ListVal [SymbolVal "trace"] -> do
         setLogging @TRACE (logPrefix "[trace] " . toStderr)
         trace "trace on"

fixme-new/lib/Fixme/Scan.hs

@@ -159,12 +159,13 @@ scanBlob fpath lbs = do
           Fixme (FixmeTag tag)
                 (FixmeTitle title)
                 Nothing
+                Nothing
                 (Just (FixmeOffset (fromIntegral lno)))
                 Nothing
                 mempty
                 mempty
 
-      _ -> Fixme mempty mempty Nothing Nothing Nothing mempty mempty
+      _ -> mempty
 
     emitFixmeStart lno lvl tagbs restbs = do
       let tag  = decodeUtf8With ignore  (LBS8.toStrict tagbs) & Text.strip

fixme-new/lib/Fixme/State.hs

@@ -10,6 +10,7 @@ module Fixme.State
   , insertCommit
   , selectCommit
   , newCommit
+  , cleanupDatabase
   , HasPredicate(..)
   ) where
 
@@ -346,3 +347,14 @@ order by f.ts nulls first
   select sql (snd predic) <&> mapMaybe (Aeson.decode @FixmeThin . fromOnly)
 
 
+cleanupDatabase :: (FixmePerks m, MonadReader FixmeEnv m) => m ()
+cleanupDatabase = do
+  warn $ red "cleanupDatabase"
+  withState $ transactional do
+    update_ [qc|delete from fixme|]
+    update_ [qc|delete from fixmeattr|]
+    update_ [qc|delete from fixmecommit|]
+    update_ [qc|delete from fixmedeleted|]
+    update_ [qc|delete from fixmerel|]
+
+

fixme-new/lib/Fixme/Types.hs

@@ -11,6 +11,7 @@ import HBS2.Git.Local
 
 import Data.Config.Suckless
 
+import Control.Applicative
 import Data.Aeson
 import Data.HashMap.Strict (HashMap)
 import Data.HashMap.Strict qualified as HM
@@ -22,6 +23,7 @@ import Data.Coerce
 import Data.Text qualified as Text
 import System.FilePath
 import Text.InterpolatedString.Perl6 (qc)
+import Lens.Micro.Platform
 
 
 pattern StringLike :: forall {c} . String -> Syntax c
@@ -79,6 +81,10 @@ newtype FixmeTimestamp = FixmeTimestamp Word64
                         deriving stock (Data,Generic)
 
 
+newtype FixmeKey  = FixmeKey Text
+                    deriving newtype (Eq,Ord,Show,ToField,FromField)
+                    deriving stock (Data,Generic)
+
 newtype FixmeOffset = FixmeOffset Word32
                      deriving newtype (Eq,Ord,Show,Num,ToField,FromField)
                      deriving stock (Data,Generic)
@@ -88,6 +94,7 @@ data Fixme =
   Fixme
   { fixmeTag       :: FixmeTag
   , fixmeTitle     :: FixmeTitle
+  , fixmeKey       :: Maybe FixmeKey
   , fixmeTs        :: Maybe FixmeTimestamp
   , fixmeStart     :: Maybe FixmeOffset
   , fixmeEnd       :: Maybe FixmeOffset
@@ -96,10 +103,24 @@ data Fixme =
   }
   deriving stock (Show,Data,Generic)
 
+instance Monoid Fixme where
+  mempty = Fixme mempty mempty Nothing Nothing Nothing Nothing mempty mempty
+
+instance Semigroup Fixme where
+  (<>) a b = b { fixmeTs  = fixmeTs b <|> fixmeTs a
+               , fixmeStart = fixmeStart b <|> fixmeStart a
+               , fixmeEnd = fixmeEnd b <|> fixmeEnd a
+               , fixmePlain = fixmePlain b
+               , fixmeAttr = fixmeAttr a <> fixmeAttr b
+               }
+
 newtype FixmeThin = FixmeThin (HashMap FixmeAttrName FixmeAttrVal)
                     deriving newtype (Semigroup,Monoid,Eq,Ord,Show,ToJSON,FromJSON)
                     deriving stock (Data,Generic)
 
+
+
+
 type FixmePerks m = ( MonadUnliftIO m
                     , MonadIO m
                     )
@@ -161,6 +182,7 @@ instance Serialise FixmeAttrName
 instance Serialise FixmeAttrVal
 instance Serialise FixmeTimestamp
 instance Serialise FixmeOffset
+instance Serialise FixmeKey
 instance Serialise Fixme