diff --git a/.fixme-new/config b/.fixme-new/config index 7a82f9c0..005a8e79 100644 --- a/.fixme-new/config +++ b/.fixme-new/config @@ -54,7 +54,7 @@ fixme-comments ";" "--" (define (ls) (report)) -(define (ls:wip) (report workflow ~ wip)) +(define (lss s) (report workflow ~ s)) (define (stage) (fixme:stage:show)) diff --git a/fixme-new/lib/Fixme/Run.hs b/fixme-new/lib/Fixme/Run.hs index 92d5c3fc..3e070ae4 100644 --- a/fixme-new/lib/Fixme/Run.hs +++ b/fixme-new/lib/Fixme/Run.hs @@ -50,7 +50,11 @@ import System.IO qualified as IO {- HLINT Ignore "Functor law" -} -runFixmeCLI :: FixmePerks m => FixmeM m a -> m a +withFixmeCLI :: FixmePerks m => FixmeEnv -> FixmeM m a -> m a +withFixmeCLI env m = do + runReaderT (fromFixmeM m) env + +runFixmeCLI :: forall a m . FixmePerks m => FixmeM m a -> m a runFixmeCLI m = do dbPath <- localDBPath git <- findGitDir @@ -127,9 +131,11 @@ runCLI = do runTop forms -runTop :: FixmePerks m => [Syntax C] -> FixmeM m () +runTop :: forall m . FixmePerks m => [Syntax C] -> FixmeM m () runTop forms = do + tvd <- newTVarIO mempty + let dict = makeDict @C do internalEntries @@ -263,8 +269,12 @@ runTop forms = do _ -> throwIO $ BadFormException @C nil entry $ bindMatch "fixme:log:import" $ nil_ \case - [StringLike fn] -> do - lift $ importFromLog fn + [StringLike fn] -> lift do + env <- ask + d <- readTVarIO tvd + importFromLog fn $ \ins -> do + void $ run d ins + updateIndexes _ -> throwIO $ BadFormException @C nil @@ -272,6 +282,20 @@ runTop forms = do fme <- lift listFixmies pure () + entry $ bindMatch "deleted" $ nil_ $ \case + [TimeStampLike _, FixmeHashLike hash] -> lift do + trace $ red "deleted" <+> pretty hash + deleteFixme hash + + _ -> pure () + + entry $ bindMatch "modified" $ nil_ $ \case + [TimeStampLike _, FixmeHashLike hash, StringLike a, StringLike b] -> do + trace $ red "modified!" <+> pretty hash <+> pretty a <+> pretty b + lift $ updateFixme Nothing hash (fromString a) (fromString b) + + _ -> pure () + entry $ bindMatch "delete" $ nil_ \case [FixmeHashLike hash] -> lift $ delete hash @@ -287,6 +311,12 @@ runTop forms = do stage <- lift selectStage liftIO $ print $ vcat (fmap pretty stage) + entry $ bindMatch "fixme:state:drop" $ nil_ $ const do + lift cleanupDatabase + + entry $ bindMatch "fixme:state:clean" $ nil_ $ const do + lift cleanupDatabase + entry $ bindMatch "fixme:stage:drop" $ nil_ $ const do lift cleanStage @@ -336,5 +366,9 @@ runTop forms = do let args = zipWith (\i s -> bindValue (mkId ("$_" <> show i)) (mkStr @C s )) [1..] argz & HM.unions - run (dict <> args) (conf <> forms) >>= eatNil display + let finalDict = dict <> args -- :: Dict C (FixmeM m) + + atomically $ writeTVar tvd finalDict + + run finalDict (conf <> forms) >>= eatNil display diff --git a/fixme-new/lib/Fixme/Run/Internal.hs b/fixme-new/lib/Fixme/Run/Internal.hs index 821d0d1d..06959be2 100644 --- a/fixme-new/lib/Fixme/Run/Internal.hs +++ b/fixme-new/lib/Fixme/Run/Internal.hs @@ -180,8 +180,18 @@ exportToLog fn = do cleanStage -importFromLog :: FixmePerks m => FilePath -> FixmeM m () -importFromLog fn = do + +sanitizeLog :: [Syntax c] -> [Syntax c] +sanitizeLog lls = flip filter lls $ \case + ListVal (SymbolVal "deleted" : _) -> True + ListVal (SymbolVal "modified" : _) -> True + _ -> False + +importFromLog :: FixmePerks m + => FilePath + -> ([Syntax C] -> FixmeM m ()) + -> FixmeM m () +importFromLog fn runIns = do fset <- listAllFixmeHashes sto <- compactStorageOpen @HbSync readonly fn @@ -196,7 +206,7 @@ importFromLog fn = do Added _ fx -> do let ha = hashObject @HbSync (serialise fx) & HashRef unless (HS.member ha fset) do - warn $ red "import" <+> viaShow (pretty ha) + debug $ red "import" <+> viaShow (pretty ha) lift $ S.yield (Right fx) w -> lift $ S.yield (Left $ fromRight mempty $ parseTop (show $ pretty w)) @@ -205,9 +215,7 @@ importFromLog fn = do let w = lefts toImport - for_ w $ \x -> do - liftIO $ print $ pretty x - -- runTop (mconcat w) + runIns (sanitizeLog $ mconcat w) unless (List.null toImport) do updateIndexes diff --git a/fixme-new/lib/Fixme/State.hs b/fixme-new/lib/Fixme/State.hs index 90fb47d3..0709a09b 100644 --- a/fixme-new/lib/Fixme/State.hs +++ b/fixme-new/lib/Fixme/State.hs @@ -685,7 +685,6 @@ updateIndexes = withState $ transactional do update_ [qc|delete from fixmejson where fixme in (select distinct id from fixmedeleted)|] - insertProcessed :: (FixmePerks m, MonadReader FixmeEnv m, Hashed HbSync w) => w -> DBPipeM m () diff --git a/fixme-new/lib/Fixme/Types.hs b/fixme-new/lib/Fixme/Types.hs index 7677f998..4d5ff28c 100644 --- a/fixme-new/lib/Fixme/Types.hs +++ b/fixme-new/lib/Fixme/Types.hs @@ -302,7 +302,7 @@ newtype FixmeM m a = FixmeM { fromFixmeM :: ReaderT FixmeEnv m a } ) -fixmeEnvBare :: FixmePerks m => m FixmeEnv +fixmeEnvBare :: forall m . FixmePerks m => m FixmeEnv fixmeEnvBare = FixmeEnv <$> newMVar ()