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,88 +577,137 @@ run what = do
              & rights
              & mconcat
 
+  runForms (sc <> s0)
 
-  for_ (sc <> s0) $ \s -> do
+  where
 
-    debug $ pretty s
+    runForms :: forall c m . (IsContext c, Data c, Data (Context c), FixmePerks m)
+             => [Syntax c]
+             -> FixmeM m ()
+    runForms ss = for_  ss $ \s -> do
 
-    case s of
+      debug $ pretty s
 
-      FixmeFiles xs -> do
+      case s of
-        t <- asks fixmeEnvFileMask
-        atomically (modifyTVar t (<> xs))
 
-      FixmePrefix tag -> do
+        FixmeFiles xs -> do
-        t <- asks fixmeEnvTags
+          t <- asks fixmeEnvFileMask
-        atomically (modifyTVar t (HS.insert tag))
+          atomically (modifyTVar t (<> xs))
 
-      FixmeGitScanFilterDays d -> do
+        FixmePrefix tag -> do
-        t <- asks fixmeEnvGitScanDays
+          t <- asks fixmeEnvTags
-        atomically (writeTVar t (Just d))
+          atomically (modifyTVar t (HS.insert tag))
 
-      ListVal [SymbolVal "fixme-file-comments", StringLike ft, StringLike b] -> do
+        FixmeGitScanFilterDays d -> do
-        let co = Text.pack b & HS.singleton
+          t <- asks fixmeEnvGitScanDays
-        t <- asks fixmeEnvFileComments
+          atomically (writeTVar t (Just d))
-        atomically (modifyTVar t (HM.insertWith (<>) (commentKey ft) co))
 
-      ListVal (SymbolVal "fixme-comments" : StringLikeList xs) -> do
+        ListVal [SymbolVal "fixme-file-comments", StringLike ft, StringLike b] -> do
-        t <- asks fixmeEnvDefComments
+          let co = Text.pack b & HS.singleton
-        let co = fmap Text.pack xs & HS.fromList
+          t <- asks fixmeEnvFileComments
-        atomically $ modifyTVar t (<> co)
+          atomically (modifyTVar t (HM.insertWith (<>) (commentKey ft) co))
 
-      ListVal (SymbolVal "fixme-attribs" : StringLikeList xs) -> do
+        ListVal (SymbolVal "fixme-comments" : StringLikeList xs) -> do
-        ta <- asks fixmeEnvAttribs
+          t <- asks fixmeEnvDefComments
-        atomically $ modifyTVar ta (<> HS.fromList (fmap fromString xs))
+          let co = fmap Text.pack xs & HS.fromList
+          atomically $ modifyTVar t (<> co)
 
-      ListVal (SymbolVal "fixme-value-set" : StringLike n : StringLikeList xs) -> do
+        ListVal (SymbolVal "fixme-attribs" : StringLikeList xs) -> do
-        t <- asks fixmeEnvAttribValues
+          ta <- asks fixmeEnvAttribs
-        let name = fromString n
+          atomically $ modifyTVar ta (<> HS.fromList (fmap fromString xs))
-        let vals = fmap fromString xs & HS.fromList
-        atomically $ modifyTVar t (HM.insertWith (<>) name vals)
 
-      Init         -> init
+        ListVal (SymbolVal "fixme-value-set" : StringLike n : StringLikeList xs) -> do
+          t <- asks fixmeEnvAttribValues
+          let name = fromString n
+          let vals = fmap fromString xs & HS.fromList
+          atomically $ modifyTVar t (HM.insertWith (<>) name vals)
 
-      ScanGitLocal args -> scanGitLocal args Nothing
+        Init         -> init
 
-      Update args -> scanGitLocal args Nothing
+        ScanGitLocal args -> scanGitLocal args Nothing
 
-      ListVal [SymbolVal "list"] -> do
+        Update args -> scanGitLocal args Nothing
-        list_ ()
 
-      ListVal (SymbolVal "list" : whatever) -> do
+        ListVal [SymbolVal "list"] -> do
-        list_ whatever
+          list_ ()
 
-      ListVal [SymbolVal "cat", FixmeHashLike hash] -> do
+        ListVal (SymbolVal "list" : whatever) -> do
-        cat_ hash
+          list_ whatever
 
-      ReadFixmeStdin -> readFixmeStdin
+        ListVal [SymbolVal "cat", FixmeHashLike hash] -> do
+          cat_ hash
 
-      ListVal [SymbolVal "print-env"] -> do
+        ListVal [SymbolVal "delete", FixmeHashLike hash] -> do
-        printEnv
+          delete hash
 
-      ListVal [SymbolVal "no-debug"] -> do
+        ListVal [SymbolVal "deleted", FixmeHashLike hash] -> do
-        setLoggingOff @DEBUG
+          deleteFixme hash
 
-      ListVal [SymbolVal "silence"] -> do
+        ReadFixmeStdin -> readFixmeStdin
-        silence
 
-      ListVal [SymbolVal "builtin:evolve"] -> do
+        ListVal [SymbolVal "print-env"] -> do
-        evolve
+          printEnv
 
-      ListVal [SymbolVal "builtin:cleanup-state"] -> do
+        ListVal (SymbolVal "hello" : xs) -> do
-        cleanupDatabase
+          notice $ "hello" <+> pretty xs
 
-      ListVal [SymbolVal "trace"] -> do
+        -- FIXME: maybe-rename-fixme-update-action
-        setLogging @TRACE (logPrefix "[trace] " . toStderr)
+        ListVal (SymbolVal "fixme-update-action" : xs) -> do
-        trace "trace on"
+          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 "no-trace"] -> do
+        ListVal (SymbolVal "fixme-play-log-action" : xs) -> do
-        trace "trace off"
+          debug $ "fixme-play-log-action" <+> pretty xs
-        setLoggingOff @TRACE
+          env <- ask
+          t <- asks fixmeEnvReadLogActions
+          let action = ReadLogAction @c $ \_ -> liftIO (withFixmeEnv env (runForms  xs))
+          atomically $ modifyTVar t (<> [action])
 
-      ListVal [SymbolVal "debug"] -> do
+        ListVal (SymbolVal "append-file" : StringLike fn : StringLikeList xs) -> do
-        setLogging @DEBUG  $ toStderr . logPrefix "[debug] "
+          debug "append-file"
+          liftIO $ for_ xs $ \x -> do
+            appendFile  fn x
+            appendFile fn "\n"
 
-      w         -> err (pretty w)
+        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
+
+        ListVal [SymbolVal "silence"] -> do
+          silence
+
+        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"
+
+        ListVal [SymbolVal "no-trace"] -> do
+          trace "trace off"
+          setLoggingOff @TRACE
+
+        ListVal [SymbolVal "debug"] -> do
+          setLogging @DEBUG  $ toStderr . logPrefix "[debug] "
+
+        w         -> err (pretty w)
 
 

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,17 +126,23 @@ 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
+  { fixmeEnvGitDir         :: Maybe FilePath
-  , fixmeEnvDb           :: DBPipeEnv
+  , fixmeEnvDb             :: DBPipeEnv
-  , fixmeEnvFileMask     :: TVar [FilePattern]
+  , fixmeEnvFileMask       :: TVar [FilePattern]
-  , fixmeEnvTags         :: TVar (HashSet FixmeTag)
+  , fixmeEnvTags           :: TVar (HashSet FixmeTag)
-  , fixmeEnvAttribs      :: TVar (HashSet FixmeAttrName)
+  , fixmeEnvAttribs        :: TVar (HashSet FixmeAttrName)
-  , fixmeEnvAttribValues :: TVar (HashMap FixmeAttrName (HashSet FixmeAttrVal))
+  , fixmeEnvAttribValues   :: TVar (HashMap FixmeAttrName (HashSet FixmeAttrVal))
-  , fixmeEnvDefComments  :: TVar (HashSet Text)
+  , fixmeEnvDefComments    :: TVar (HashSet Text)
-  , fixmeEnvFileComments :: TVar (HashMap FilePath (HashSet Text))
+  , fixmeEnvFileComments   :: TVar (HashMap FilePath (HashSet Text))
-  , fixmeEnvGitScanDays  :: TVar (Maybe Integer)
+  , fixmeEnvGitScanDays    :: TVar (Maybe Integer)
+  , fixmeEnvUpdateActions  :: TVar [UpdateAction]
+  , fixmeEnvReadLogActions :: TVar [ReadLogAction]
   }