From 57a1a5e81bbd19447270f43a2ffab9db3aef8017 Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Fri, 17 May 2024 12:09:10 +0300 Subject: [PATCH] wip, ok --- .fixme-new/config | 2 +- .fixme-new/log | 5 +++++ fixme-new/lib/Fixme/Run.hs | 34 ++++++++++++++++++++++++++++++++-- fixme-new/lib/Fixme/State.hs | 19 +++++++++++++++++-- fixme-new/lib/Fixme/Types.hs | 11 +++++++++-- 5 files changed, 64 insertions(+), 7 deletions(-) diff --git a/.fixme-new/config b/.fixme-new/config index 6837ea64..5b10be29 100644 --- a/.fixme-new/config +++ b/.fixme-new/config @@ -38,7 +38,7 @@ fixme-comments ";" "--" ) (fixme-play-log-action -; (hello kitty) + (hello kitty) ) (define-template short diff --git a/.fixme-new/log b/.fixme-new/log index 23b84e0f..f1774227 100644 --- a/.fixme-new/log +++ b/.fixme-new/log @@ -1,2 +1,7 @@ deleted "6R2raAzjbViHZVk24zwUr7rwgfepHTdXeW6Lbqw3q25A" deleted "DtcQir9mHe7R5ixYGXTbsXGPeVGV8TqAMmrvYgGy1wGB" +modified "2XpT9uxrz3yu9jtYtu46jfs8ZFr8s3PVAZREJWTCSdYx" "workflow" "done" +modified 0 "2XpT9uxrz3yu9jtYtu46jfs8ZFr8s3PVAZREJWTCSdYx" "workflow" "done" +modified "2XpT9uxrz3yu9jtYtu46jfs8ZFr8s3PVAZREJWTCSdYx" "workflow" "done" +modified "2XpT9uxrz3yu9jtYtu46jfs8ZFr8s3PVAZREJWTCSdYx" "workflow" "done" +modified "2XpT9uxrz3yu9jtYtu46jfs8ZFr8s3PVAZREJWTCSdYx" "workflow" "backlog" diff --git a/fixme-new/lib/Fixme/Run.hs b/fixme-new/lib/Fixme/Run.hs index 7e6fcf86..08d004f1 100644 --- a/fixme-new/lib/Fixme/Run.hs +++ b/fixme-new/lib/Fixme/Run.hs @@ -583,6 +583,22 @@ delete txt = do liftIO $ what (Literal noContext syn) +modify_ :: FixmePerks m => Text -> String -> String -> FixmeM m () +modify_ txt a b = do + acts <- asks fixmeEnvUpdateActions >>= readTVarIO + + void $ runMaybeT do + + ha <- toMPlus =<< lift (selectFixmeHash txt) + let syn = mkLit @Text [qc|modified "{pretty ha}" "{a}" "{b}"|] + + debug $ red $ pretty syn + + for_ acts $ \(UpdateAction what) -> do + liftIO $ what (Literal noContext syn) + + + printEnv :: FixmePerks m => FixmeM m () printEnv = do g <- asks fixmeEnvGitDir @@ -646,6 +662,7 @@ splitForms s0 = runIdentity $ S.toList_ (go mempty s0) sanitizeLog :: [Syntax c] -> [Syntax c] sanitizeLog lls = flip filter lls $ \case ListVal (SymbolVal "deleted" : _) -> True + ListVal (SymbolVal "modified" : _) -> True _ -> False pattern Template :: forall {c}. Maybe Id -> [Syntax c] -> [Syntax c] @@ -757,6 +774,17 @@ run what = do ListVal [SymbolVal "delete", FixmeHashLike hash] -> do delete hash + ListVal [SymbolVal "modify", FixmeHashLike hash, StringLike a, StringLike b] -> do + modify_ hash a b + + ListVal [SymbolVal "modified", TimeStampLike t, FixmeHashLike hash, StringLike a, StringLike b] -> do + debug $ green $ pretty s + updateFixme (Just t) hash (fromString a) (fromString b) + + ListVal [SymbolVal "modified", FixmeHashLike hash, StringLike a, StringLike b] -> do + debug $ green $ pretty s + updateFixme Nothing hash (fromString a) (fromString b) + ListVal [SymbolVal "deleted", FixmeHashLike hash] -> do deleteFixme hash @@ -769,7 +797,7 @@ run what = do notice $ "hello" <+> pretty xs ListVal (SymbolVal "define-template" : SymbolVal who : IsSimpleTemplate xs) -> do - debug $ "define-template" <+> pretty who <+> "simple" <+> hsep (fmap pretty xs) + trace $ "define-template" <+> pretty who <+> "simple" <+> hsep (fmap pretty xs) t <- asks fixmeEnvTemplates atomically $ modifyTVar t (HM.insert who (Simple (SimpleTemplate xs))) @@ -785,7 +813,9 @@ run what = do env <- ask t <- asks fixmeEnvUpdateActions let repl syn = [ ( "$1", syn ) ] - let action = UpdateAction @c $ \syn -> liftIO (withFixmeEnv env (runForms (inject (repl syn) xs))) + let action = UpdateAction @c $ \syn -> do + liftIO (withFixmeEnv env (runForms (inject (repl syn) xs))) + atomically $ modifyTVar t (<> [action]) ListVal (SymbolVal "fixme-play-log-action" : xs) -> do diff --git a/fixme-new/lib/Fixme/State.hs b/fixme-new/lib/Fixme/State.hs index 1723d53d..f212adf5 100644 --- a/fixme-new/lib/Fixme/State.hs +++ b/fixme-new/lib/Fixme/State.hs @@ -8,6 +8,7 @@ module Fixme.State , selectFixmeHash , selectFixme , deleteFixme + , updateFixme , insertCommit , insertBlob , selectObjectHash @@ -154,8 +155,8 @@ createTables = do row_number() over (partition by fixme, name order by ts desc nulls first) as rn from fixmeattr where not ({commits}) - ), - ranked2 as ( + ) + , ranked2 as ( select fixme, name, @@ -520,6 +521,20 @@ deleteFixme hash = withState do |] (Only hash) +updateFixme :: (FixmePerks m,MonadReader FixmeEnv m) + => Maybe FixmeTimestamp + -> Text + -> FixmeAttrName + -> FixmeAttrVal + -> m () + +updateFixme ts hash a b = withState do + warn $ red "updateFixme" <+> pretty hash + insert [qc| insert into fixmeattr (fixme,ts,name,value) + values (?,coalesce(?,strftime('%s', 'now')),?,?) + on conflict(fixme,ts,name) do update set value = excluded.value + |] (hash,ts,a,b) + updateIndexes :: (FixmePerks m, MonadReader FixmeEnv m) => m () updateIndexes = withState $ transactional do update_ [qc|delete from fixmeactual|] diff --git a/fixme-new/lib/Fixme/Types.hs b/fixme-new/lib/Fixme/Types.hs index cba19fca..cd093beb 100644 --- a/fixme-new/lib/Fixme/Types.hs +++ b/fixme-new/lib/Fixme/Types.hs @@ -24,11 +24,9 @@ import Data.Maybe import Data.Coerce import Data.Text qualified as Text import Data.List qualified as List -import Data.Either import Data.Map qualified as Map import System.FilePath import Text.InterpolatedString.Perl6 (qc) -import Lens.Micro.Platform pattern StringLike :: forall {c} . String -> Syntax c @@ -40,6 +38,10 @@ pattern StringLikeList e <- (stringLikeList -> e) pattern FixmeHashLike :: forall {c} . Text -> Syntax c pattern FixmeHashLike e <- (fixmeHashFromSyn -> Just e) + +pattern TimeStampLike :: forall {c} . FixmeTimestamp -> Syntax c +pattern TimeStampLike e <- (tsFromFromSyn -> Just e) + stringLike :: Syntax c -> Maybe String stringLike = \case LitStrVal s -> Just $ Text.unpack s @@ -57,6 +59,11 @@ fixmeHashFromSyn = \case _ -> Nothing +tsFromFromSyn :: Syntax c -> Maybe FixmeTimestamp +tsFromFromSyn = \case + LitIntVal n -> Just (fromIntegral n) + _ -> Nothing + newtype FixmeTag = FixmeTag { fromFixmeTag :: Text } deriving newtype (Eq,Ord,Show,IsString,Hashable,Semigroup,Monoid,ToField,FromField) deriving stock (Data,Generic)