wip

.fixme-new/config

@@ -29,6 +29,18 @@ fixme-file-comments "*.scm" ";"
 
 fixme-comments ";" "--"
 
+(fixme-update-action
+  (append-file ".fixme-new/log" $1)
+)
+
+(fixme-play-log-action
+  (play-log-file ".fixme-new/log")
+)
+
+(fixme-play-log-action
+)
+
 update
 
 
+

fixme-new/lib/Fixme/Run.hs

@@ -119,6 +119,8 @@ runFixmeCLI m = do
             <*>  newTVarIO mempty
             <*>  newTVarIO defCommentMap
             <*>  newTVarIO Nothing
+            <*>  newTVarIO mempty
+            <*>  newTVarIO mempty
 
   runReaderT ( setupLogger >> fromFixmeM (evolve >> m) ) env
                  `finally` flushLoggers
@@ -437,13 +439,22 @@ scanGitLocal args p =  do
             liftIO $ withFixmeEnv env $ withState $ transactional do
               for_ fixmies insertFixme
 
+
           _ -> fucked ()
 
+      unless ( ScanRunDry `elem` args ) do
+        lift runLogActions
 
       liftIO $ withFixmeEnv env $ withState $ transactional do
         for_ co $ \w -> do
           insertCommit (view _1 w)
 
+runLogActions :: FixmePerks m => FixmeM m ()
+runLogActions = do
+  debug $ yellow "runLogActions"
+  actions <- asks fixmeEnvReadLogActions >>= readTVarIO
+  for_ actions $ \(ReadLogAction a) -> do
+    liftIO (a (List noContext []))
 
 startGitCatFile ::  (FixmePerks m, MonadReader FixmeEnv m) => m (Process Handle Handle ())
 startGitCatFile = do
@@ -476,6 +487,21 @@ cat_ hash = void $ flip runContT pure do
 
     notice $ pretty fme
 
+delete :: FixmePerks m => Text -> FixmeM m ()
+delete txt = do
+  acts <- asks fixmeEnvUpdateActions >>= readTVarIO
+
+  void $ runMaybeT do
+
+    ha <- toMPlus =<< lift (selectFixmeHash txt)
+    let syn = mkLit @Text [qc|deleted "{pretty ha}"|]
+
+    debug $ red "deleted" <+> pretty ha
+
+    for_ acts $ \(UpdateAction what) -> do
+      liftIO $ what (Literal noContext syn)
+
+
 printEnv :: FixmePerks m => FixmeM m ()
 printEnv = do
   g <- asks fixmeEnvGitDir
@@ -519,6 +545,13 @@ help :: FixmePerks m => m ()
 help = do
   notice "this is help  message"
 
+-- FIXME: tied-context-type
+inject :: forall a c . (Data c, Data (Context c), Data a) => [(Id,Syntax c)] -> a -> a
+inject repl target =
+  flip transformBi target $ \case
+   w@(SymbolVal x) ->  fromMaybe w (Map.lookup x rmap)
+   other -> other
+   where rmap = Map.fromList repl
 
 splitForms :: [String] -> [[String]]
 splitForms s0 = runIdentity $ S.toList_ (go mempty s0)
@@ -530,6 +563,11 @@ splitForms s0 = runIdentity $ S.toList_ (go mempty s0)
 
     emit = S.yield . reverse
 
+sanitizeLog :: [Syntax c] -> [Syntax c]
+sanitizeLog lls = flip filter lls $ \case
+  ListVal (SymbolVal "deleted" : _) -> True
+  _ -> False
+
 run :: FixmePerks m => [String] -> FixmeM m ()
 run what = do
 
@@ -539,8 +577,14 @@ run what = do
              & rights
              & mconcat
 
+  runForms (sc <> s0)
 
-  for_ (sc <> s0) $ \s -> do
+  where
+
+    runForms :: forall c m . (IsContext c, Data c, Data (Context c), FixmePerks m)
+             => [Syntax c]
+             -> FixmeM m ()
+    runForms ss = for_  ss $ \s -> do
 
       debug $ pretty s
 
@@ -593,11 +637,54 @@ run what = do
         ListVal [SymbolVal "cat", FixmeHashLike hash] -> do
           cat_ hash
 
+        ListVal [SymbolVal "delete", FixmeHashLike hash] -> do
+          delete hash
+
+        ListVal [SymbolVal "deleted", FixmeHashLike hash] -> do
+          deleteFixme hash
+
         ReadFixmeStdin -> readFixmeStdin
 
         ListVal [SymbolVal "print-env"] -> do
           printEnv
 
+        ListVal (SymbolVal "hello" : xs) -> do
+          notice $ "hello" <+> pretty xs
+
+        -- FIXME: maybe-rename-fixme-update-action
+        ListVal (SymbolVal "fixme-update-action" : xs) -> do
+          debug $ "fixme-update-action" <+> pretty xs
+          env <- ask
+          t <- asks fixmeEnvUpdateActions
+          let repl syn = [ ( "$1", syn ) ]
+          let action = UpdateAction @c $ \syn -> liftIO (withFixmeEnv env (runForms (inject (repl syn) xs)))
+          atomically $ modifyTVar t (<> [action])
+
+        ListVal (SymbolVal "fixme-play-log-action" : xs) -> do
+          debug $ "fixme-play-log-action" <+> pretty xs
+          env <- ask
+          t <- asks fixmeEnvReadLogActions
+          let action = ReadLogAction @c $ \_ -> liftIO (withFixmeEnv env (runForms  xs))
+          atomically $ modifyTVar t (<> [action])
+
+        ListVal (SymbolVal "append-file" : StringLike fn : StringLikeList xs) -> do
+          debug "append-file"
+          liftIO $ for_ xs $ \x -> do
+            appendFile  fn x
+            appendFile fn "\n"
+
+        ListVal [SymbolVal "play-log-file", StringLike fn] -> do
+          debug $ yellow "play-log-file" <+> pretty fn
+          -- FIXME: just-for-in-case-sanitize-input
+          what <- try @_ @IOException (liftIO $ readFile fn)
+                    <&> fromRight mempty
+                    <&> parseTop
+                    <&> fromRight mempty
+                    <&> sanitizeLog
+
+          env <- ask
+          liftIO $ withFixmeEnv env (runForms what)
+
         ListVal [SymbolVal "no-debug"] -> do
           setLoggingOff @DEBUG
 

fixme-new/lib/Fixme/State.hs

@@ -7,6 +7,7 @@ module Fixme.State
   , selectFixmeThin
   , selectFixmeHash
   , selectFixme
+  , deleteFixme
   , insertCommit
   , selectCommit
   , newCommit
@@ -169,6 +170,7 @@ createTables = do
         join fixme f on a.fixme = f.id
       where
         a.name = 'fixme-key'
+        and not exists (select null from fixmedeleted d where a.fixme = id limit 1)
     ),
     rn AS (
       select
@@ -180,7 +182,8 @@ createTables = do
         fixme f
         join a1 a on f.id = a.fixme and a.name = 'fixme-key'
     )
-    select id as fixme, fixmekey from rn where rn = 1;
+    select id as fixme, fixmekey from rn
+      where rn = 1
     |]
 
 insertCommit :: FixmePerks m => GitHash -> DBPipeM m ()
@@ -402,3 +405,12 @@ cleanupDatabase = do
     update_ [qc|delete from fixmerel|]
 
 
+deleteFixme :: (FixmePerks m,MonadReader FixmeEnv m) => Text -> m ()
+deleteFixme hash = withState do
+  trace $ red "deleteFixme" <+> pretty hash
+  insert [qc| insert into fixmedeleted (id,ts,deleted)
+              values (?,(strftime('%s', 'now')),true)
+              on conflict(id,ts) do nothing
+            |] (Only hash)
+
+

fixme-new/lib/Fixme/Types.hs

@@ -126,6 +126,10 @@ type FixmePerks m = ( MonadUnliftIO m
                     )
 
 
+data UpdateAction = forall c . IsContext c => UpdateAction { runUpdateAction :: Syntax c -> IO () }
+
+data ReadLogAction = forall c . IsContext c => ReadLogAction { runReadLog :: Syntax c -> IO () }
+
 data FixmeEnv =
   FixmeEnv
   { fixmeEnvGitDir         :: Maybe FilePath
@@ -137,6 +141,8 @@ data FixmeEnv =
   , fixmeEnvDefComments    :: TVar (HashSet Text)
   , fixmeEnvFileComments   :: TVar (HashMap FilePath (HashSet Text))
   , fixmeEnvGitScanDays    :: TVar (Maybe Integer)
+  , fixmeEnvUpdateActions  :: TVar [UpdateAction]
+  , fixmeEnvReadLogActions :: TVar [ReadLogAction]
   }