From 9cde6cb7d543f12ba907a04d23adbeecea7df549 Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Mon, 13 May 2024 09:25:00 +0300 Subject: [PATCH] wip --- .fixme-new/config | 9 +++--- fixme-new/fixme.cabal | 1 + fixme-new/lib/Fixme/Run.hs | 56 ++++++++++++++++++++++++++++++++++-- fixme-new/lib/Fixme/Scan.hs | 3 +- fixme-new/lib/Fixme/State.hs | 12 ++++++++ fixme-new/lib/Fixme/Types.hs | 22 ++++++++++++++ 6 files changed, 95 insertions(+), 8 deletions(-) diff --git a/.fixme-new/config b/.fixme-new/config index 1fae3725..55e9b3cd 100644 --- a/.fixme-new/config +++ b/.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 diff --git a/fixme-new/fixme.cabal b/fixme-new/fixme.cabal index e1575023..e99c37f3 100644 --- a/fixme-new/fixme.cabal +++ b/fixme-new/fixme.cabal @@ -73,6 +73,7 @@ common shared-properties , filepath , filepattern , generic-lens + , generic-deriving , interpolatedstring-perl6 , memory , microlens-platform diff --git a/fixme-new/lib/Fixme/Run.hs b/fixme-new/lib/Fixme/Run.hs index 2f3fd06d..1cc57e74 100644 --- a/fixme-new/lib/Fixme/Run.hs +++ b/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" diff --git a/fixme-new/lib/Fixme/Scan.hs b/fixme-new/lib/Fixme/Scan.hs index 28a54c9e..03a65412 100644 --- a/fixme-new/lib/Fixme/Scan.hs +++ b/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 diff --git a/fixme-new/lib/Fixme/State.hs b/fixme-new/lib/Fixme/State.hs index 96cbcc6f..462fe35b 100644 --- a/fixme-new/lib/Fixme/State.hs +++ b/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|] + + diff --git a/fixme-new/lib/Fixme/Types.hs b/fixme-new/lib/Fixme/Types.hs index de18dc55..cf8a83b2 100644 --- a/fixme-new/lib/Fixme/Types.hs +++ b/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