wip

.fixme-new/config

@@ -23,6 +23,8 @@ fixme-value-set scope mvp-0 mvp-1 backlog
 
 fixme-files **/*.txt docs/devlog.md
 fixme-files **/*.hs
+fixme-exclude **/.**
+fixme-exclude dist-newstyle
 
 fixme-file-comments "*.scm" ";"
 

fixme-new/lib/Fixme/Config.hs

@@ -5,7 +5,7 @@ import Fixme.Types
 
 import HBS2.System.Dir
 import System.Environment
-import System.Directory
+import System.Directory (getXdgDirectory, XdgDirectory(..))
 
 binName :: FixmePerks m => m FilePath
 binName = liftIO getProgName
@@ -16,6 +16,9 @@ localConfigDir = do
   b <- binName
   pure (p </> ("." <> b))
 
+fixmeWorkDir :: FixmePerks m => m FilePath
+fixmeWorkDir = localConfigDir <&> takeDirectory >>= canonicalizePath
+
 localConfig:: FixmePerks m => m FilePath
 localConfig = localConfigDir <&> (</> "config")
 

fixme-new/lib/Fixme/Run.hs

@@ -10,6 +10,8 @@ import Fixme.Scan.Git.Local as Git
 import Fixme.Scan as Scan
 import Fixme.Log
 
+import Data.Config.Suckless.Script.File
+
 import HBS2.KeyMan.Keys.Direct
 
 import HBS2.Git.Local.CLI
@@ -59,6 +61,8 @@ import Control.Monad.Trans.Maybe
 import System.IO.Temp as Temp
 import System.IO qualified as IO
 
+import Streaming.Prelude qualified as S
+
 {- HLINT ignore "Functor law" -}
 
 
@@ -121,8 +125,10 @@ runFixmeCLI m = do
             <*>  newTVarIO mempty
             <*>  newTVarIO mempty
             <*>  newTVarIO mempty
+            <*>  newTVarIO mempty
             <*>  newTVarIO defCommentMap
             <*>  newTVarIO Nothing
+            <*>  newTVarIO mzero
             <*>  newTVarIO mempty
             <*>  newTVarIO mempty
             <*>  newTVarIO defaultCatAction
@@ -163,7 +169,7 @@ silence = do
   setLoggingOff @TRACE
 
 
-readConfig :: FixmePerks m => FixmeM m [Syntax C]
+readConfig :: (FixmePerks m) => FixmeM m [Syntax C]
 readConfig = do
 
   user <- userConfigs
@@ -175,6 +181,8 @@ readConfig = do
       <&> parseTop
       >>= either (error.show) pure
 
+  updateScanMagic
+
   pure $ mconcat w
 
 
@@ -223,16 +231,26 @@ runTop forms = do
 
        entry $ bindMatch "fixme-attribs" $ nil_ \case
         StringLikeList xs -> do
+          w <- fixmeWorkDir
           ta <- lift $ asks fixmeEnvAttribs
-          atomically $ modifyTVar ta (<> HS.fromList (fmap fromString xs))
+          atomically $ modifyTVar ta (<> HS.fromList (fmap (fromString . (</> w)) xs))
 
         _ -> throwIO $ BadFormException @C nil
 
 
        entry $ bindMatch "fixme-files" $ nil_ \case
         StringLikeList xs -> do
+          w <- fixmeWorkDir
           t <- lift $ asks fixmeEnvFileMask
-          atomically (modifyTVar t (<> xs))
+          atomically (modifyTVar t (<> fmap (w </>) xs))
+
+        _ -> throwIO $ BadFormException @C nil
+
+       entry $ bindMatch "fixme-exclude" $ nil_ \case
+        StringLikeList xs -> do
+          w <- fixmeWorkDir
+          t <- lift $ asks fixmeEnvFileExclude
+          atomically (modifyTVar t (<> fmap (w </>) xs))
 
         _ -> throwIO $ BadFormException @C nil
 
@@ -291,29 +309,55 @@ runTop forms = do
 
         _ -> throwIO $ BadFormException @C nil
 
-       entry $ bindMatch "dump" $ nil_ \case
+       entry $ bindMatch "fixme:scan-magic" $ nil_ $ const do
-        [FixmeHashLike h] -> do
+          magic <- lift $ asks fixmeEnvScanMagic >>= readTVarIO
-          lift $ dumpFixme h
+          liftIO $ print $ pretty magic
 
-        _ -> throwIO $ BadFormException @C nil
+       entry $ bindMatch "fixme:path" $ nil_ $ const do
+          path <- lift fixmeWorkDir
+          liftIO $ print $ pretty path
 
-       entry $ bindMatch "cat" $ nil_ \case
+       entry $ bindMatch "fixme:files" $ nil_ $ const do
-        [SymbolVal "metadata", FixmeHashLike hash] -> do
+          w <- lift fixmeWorkDir
-          lift $ catFixmeMetadata hash
+          incl <- lift (asks fixmeEnvFileMask >>= readTVarIO)
+          excl <- lift (asks fixmeEnvFileExclude >>= readTVarIO)
+          glob incl excl w  $ \fn -> do
+            liftIO $ putStrLn (makeRelative w fn)
+            pure True
 
-        [FixmeHashLike hash] -> do
+       entry $ bindMatch "fixme:state:drop" $ nil_ $ const $ lift do
-          lift $ catFixme hash
+        cleanupDatabase
 
-        _ -> throwIO $ BadFormException @C nil
+       entry $ bindMatch "fixme:state:cleanup" $ nil_ $ const $ lift do
+        cleanupDatabase
 
-       entry $ bindMatch "report" $ nil_ \case
+       entry $ bindMatch "fixme:scan:import" $ nil_ $ const $ lift do
-        [] -> lift $ list_ Nothing ()
+          fxs0 <- scanFiles
 
-        (SymbolVal "--template" : StringLike name : query) -> do
+          fxs <- flip filterM fxs0 $ \fme -> do
-          lift $ list_ (Just (fromString name)) query
+                   let fn = HM.lookup "file" (fixmeAttr fme) <&> Text.unpack . coerce
+                   seen <- maybe1 fn (pure False) selectIsAlreadyScanned
+                   pure (not seen)
 
-        query -> do
+          withState $ transactional do
-          lift $ list_ mzero query
+            for_ fxs $ \fme -> do
+              notice $ "fixme" <+> pretty (fixmeKey fme)
+              insertFixme fme
+              -- TODO: remove-code-duplucation
+              let fn = HM.lookup "file" (fixmeAttr fme) <&> Text.unpack . coerce
+              for_ fn insertScanned
+
+       entry $ bindMatch "fixme:scan:list" $ nil_ $ const do
+          fxs <- lift scanFiles
+          for_ fxs $ \fme -> do
+            liftIO $ print $ pretty fme
+
+       -- TODO: some-shit
+       --  one
+
+
+       -- TODO: some-shit
+       --   two
 
        entry $ bindMatch "env:show" $ nil_ $ const $ do
         lift printEnv
@@ -334,87 +378,13 @@ runTop forms = do
         co <- lift listCommits <&> fmap (mkStr @C . view _1)
         pure $ mkList co
 
-       entry $ bindMatch "git:refs" $ const do
-         refs <- lift $ listRefs False
-
-         elems <- for refs $ \(h,r) -> do
-          pure $ mkList @C [mkStr h, mkSym ".", mkStr r]
-
-         pure $ mkList elems
-
        -- TODO: implement-fixme:refchan:export
        entry $ bindMatch "fixme:refchan:export" $ nil_ \case
         _ -> none
 
-       -- TODO: implement-fixme:refchan:import
-
-       entry $ bindMatch "fixme:log:export" $ nil_ \case
-        [StringLike fn] -> do
-           lift $ exportToLog fn
-
-        _ -> throwIO $ BadFormException @C nil
-
-       entry $ bindMatch "fixme:log:import" $ nil_ \case
-        [StringLike fn] -> lift do
-           env <- ask
-           d   <- readTVarIO tvd
-           importFromLog fn $ \ins -> do
-              void $ run d ins
-           updateIndexes
-
-        _ -> throwIO $ BadFormException @C nil
-
-       entry $ bindMatch "fixme:list:poor" $ nil_ $ const 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
-
-         _ -> throwIO $ BadFormException @C nil
-
-       entry $ bindMatch "modify" $ nil_ \case
-         [FixmeHashLike hash, StringLike a, StringLike b] -> do
-           lift $ modify_ hash a b
-
-         _ -> throwIO $ BadFormException @C nil
-
-       entry $ bindMatch "fixme:stage:show" $ nil_ $ const 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
-
-       entry $ bindMatch "fixme:stage:clean" $ nil_ $ const do
-          lift cleanStage
-
-       entry $ bindMatch "fixme:config:path" $ const do
-        co <- localConfig
-        pure $ mkStr @C co
-
        entry $ bindMatch "git:import" $ nil_ $ const do
-        lift $ scanGitLocal mempty Nothing
+        error "not implemented yet"
+        -- lift $ scanGitLocal mempty Nothing
 
        entry $ bindMatch "git:blobs" $  \_ -> do
         blobs <- lift listRelevantBlobs
@@ -436,11 +406,11 @@ runTop forms = do
 
         notice $ "1. read refchan" <+> pretty (AsBase58 rchan)
 
-        fxs <- lift $ selectFixmeThin ()
+        -- fxs <- lift $ selectFixmeThin ()
 
-        for_ fxs $ \(FixmeThin x) -> void $ runMaybeT do
+--         for_ fxs $ \(FixmeThin x) -> void $ runMaybeT do
-          h <- HM.lookup "fixme-hash" x & toMPlus
+--           h <- HM.lookup "fixme-hash" x & toMPlus
-          notice $ pretty h
+--           notice $ pretty h
 
         notice "2. read issues from state"
         notice "3. discover new issues"

fixme-new/lib/Fixme/Run/Internal.hs

@@ -20,7 +20,9 @@ import HBS2.Storage
 import HBS2.Storage.Compact
 import HBS2.System.Dir
 import DBPipe.SQLite hiding (field)
+
 import Data.Config.Suckless
+import Data.Config.Suckless.Script.File
 
 import Data.Aeson.Encode.Pretty as Aeson
 import Data.ByteString (ByteString)
@@ -46,6 +48,8 @@ import Control.Monad.Trans.Cont
 import Control.Monad.Trans.Maybe
 import System.IO.Temp as Temp
 import System.IO qualified as IO
+import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)
+import System.Directory (getModificationTime)
 
 
 import Streaming.Prelude qualified as S
@@ -53,6 +57,8 @@ import Streaming.Prelude qualified as S
 pattern IsSimpleTemplate ::  forall {c} . [Syntax c] -> Syntax c
 pattern IsSimpleTemplate xs <- ListVal (SymbolVal "simple" : xs)
 
+{- HLINT ignore "Functor law" -}
+
 defaultTemplate :: HashMap Id FixmeTemplate
 defaultTemplate = HM.fromList [ ("default", Simple (SimpleTemplate short)) ]
   where
@@ -93,6 +99,7 @@ printEnv :: FixmePerks m => FixmeM m ()
 printEnv = do
   g <- asks fixmeEnvGitDir >>= readTVarIO
   masks <- asks fixmeEnvFileMask >>= readTVarIO
+  excl  <- asks fixmeEnvFileExclude >>= readTVarIO
   tags  <- asks fixmeEnvTags >>= readTVarIO
   days  <- asks fixmeEnvGitScanDays >>= readTVarIO
   comments1 <- asks fixmeEnvDefComments >>= readTVarIO <&> HS.toList
@@ -110,6 +117,9 @@ printEnv = do
   for_ masks $ \m -> do
     liftIO $ print $ "fixme-files" <+> dquotes (pretty m)
 
+  for_ excl $ \m -> do
+    liftIO $ print $ "fixme-exclude" <+> dquotes (pretty m)
+
   for_ days $ \d -> do
     liftIO $ print $ "fixme-git-scan-filter-days" <+> pretty d
 
@@ -144,182 +154,44 @@ printEnv = do
     liftIO $ print $ parens ("define-macro" <+> pretty n <+> pretty syn)
 
 
-exportToLog :: FixmePerks m => FilePath -> FixmeM m ()
+scanFiles :: FixmePerks m => FixmeM m [Fixme]
-exportToLog fn = do
+scanFiles = do
-  e <- getEpoch
+  w <- fixmeWorkDir
-  warn $ red "EXPORT-FIXMIES" <+> pretty fn
+  incl <- asks fixmeEnvFileMask >>= readTVarIO
-  sto <- compactStorageOpen @HbSync mempty fn
+  excl <- asks fixmeEnvFileExclude >>= readTVarIO
-  fx <- selectFixmeThin ()
-  for_ fx $ \(FixmeThin m) -> void $ runMaybeT do
-    h <- HM.lookup "fixme-hash" m & toMPlus
-    loaded <- lift (selectFixme (coerce h)) >>= toMPlus
-    let what = Added e loaded
-    let k = mkKey what
-    get sto k >>= guard . isNothing
-    put sto (mkKey what) (LBS.toStrict $ serialise what)
-    warn $ red "export" <+> pretty h
 
-  what <- selectStage
+  keys <- newTVarIO (mempty :: HashMap Text Integer)
 
-  for_ what $ \w -> do
+  S.toList_ do
-    let k = mkKey w
-    v0 <- get sto k <&> fmap (deserialiseOrFail @CompactAction .  LBS.fromStrict)
-    case v0 of
-      Nothing -> do
-        put sto k (LBS.toStrict $ serialise w)
 
-      Just (Left{}) -> do
+    glob incl excl w  $ \fn -> do
-        put sto k (LBS.toStrict $ serialise w)
 
-      Just (Right prev) | getSequence w > getSequence prev -> do
+      ts <- liftIO $ getModificationTime fn <&> round . utcTimeToPOSIXSeconds
-        put sto k (LBS.toStrict $ serialise w)
 
-      _ -> pure ()
+      let fnShort = makeRelative w fn
 
-  compactStorageClose sto
+      lbs <- liftIO (try @_ @IOException $ LBS.readFile fn)
+               <&> fromRight mempty
 
-  cleanStage
+      fxs0 <- lift $ scanBlob (Just fn) lbs
+
+      for_ fxs0 $ \fme -> do
+        let key = fromString (fnShort <> "#") <> coerce (fixmeTitle fme) <> ":" :: Text
+        atomically $ modifyTVar keys (HM.insertWith (+) key 1)
+        no <- readTVarIO keys <&> HM.lookup key <&> fromMaybe 0
+        let keyText = key <> fromString (show no)
+        let keyHash = FixmeKey $ fromString $ show $ pretty $ hashObject @HbSync (serialise keyText)
+        let f2 = mempty { fixmeTs = Just (fromIntegral ts)
+                        , fixmeKey = Just keyHash
+                        , fixmeAttr = HM.fromList
+                            [   ( "fixme-key-string", FixmeAttrVal keyText)
+                              , ( "file", FixmeAttrVal (fromString fnShort))
+                            ]
+                        , fixmePlain = fixmePlain fme
+                        }
+        let fmeNew = (fme <> f2) & fixmeDerivedFields
+        S.yield fmeNew
+
+      pure True
 
 
-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
-  ks   <- keys sto
-
-  toImport <- S.toList_ do
-    for_ ks $ \k -> runMaybeT do
-      v <- get sto k & MaybeT
-      what <- deserialiseOrFail @CompactAction (LBS.fromStrict v) & toMPlus
-
-      case what of
-        Added _ fx  -> do
-          let ha = hashObject @HbSync (serialise fx) & HashRef
-          unless (HS.member ha fset) do
-            debug $ red "import" <+> viaShow (pretty ha)
-            lift $ S.yield (Right fx)
-        w -> lift $ S.yield (Left $ fromRight mempty $ parseTop (show $ pretty w))
-
-  withState $ transactional do
-    for_ (rights  toImport) insertFixme
-
-  let w = lefts toImport
-
-  runIns (sanitizeLog $ mconcat w)
-
-  unless (List.null toImport) do
-    updateIndexes
-
-  compactStorageClose sto
-
-
-list_ :: (FixmePerks m, HasPredicate a) => Maybe Id -> a -> FixmeM m ()
-list_ tpl a = do
-
-  tpl <- asks fixmeEnvTemplates >>= readTVarIO
-            <&> HM.lookup (fromMaybe "default" tpl)
-
-  fixmies <- selectFixmeThin a
-
-  case tpl of
-    Nothing-> do
-      liftIO $ LBS.putStr $ Aeson.encodePretty fixmies
-
-    Just (Simple (SimpleTemplate simple)) -> do
-      for_ fixmies $ \(FixmeThin attr) -> do
-        let subst = [ (mkId k, mkStr @C v) | (k,v) <- HM.toList attr ]
-        let what = render (SimpleTemplate (inject  subst simple))
-                      & fromRight "render error"
-
-        liftIO $ hPutDoc stdout what
-
-catFixmeMetadata :: FixmePerks m => Text -> FixmeM m ()
-catFixmeMetadata = cat_ True
-
-catFixme :: FixmePerks m => Text -> FixmeM m ()
-catFixme = cat_ False
-
-dumpFixme :: FixmePerks m => Text -> FixmeM m ()
-dumpFixme hash = do
-  flip runContT pure do
-    mha <- lift $ selectFixmeHash hash
-    ha <- ContT $ maybe1 mha (pure ())
-    fme' <- lift $ selectFixme ha
-    liftIO $ print $ pretty fme'
-
-cat_ :: FixmePerks m => Bool -> Text -> FixmeM m ()
-cat_ metaOnly hash = do
-
-  (before,after)  <- asks fixmeEnvCatContext >>= readTVarIO
-  gd  <- fixmeGetGitDirCLIOpt
-
-  CatAction action <- asks fixmeEnvCatAction >>= readTVarIO
-
-  void $ flip runContT pure do
-    callCC \exit -> do
-
-      mha <- lift $ selectFixmeHash hash
-
-      ha <- ContT $ maybe1 mha (pure ())
-
-      fme' <- lift $ selectFixme ha
-
-      Fixme{..} <- ContT $ maybe1 fme' (pure ())
-
-      when metaOnly do
-        for_ (HM.toList fixmeAttr) $ \(k,v) -> do
-          liftIO $ print $ (pretty k <+> pretty v)
-        exit ()
-
-      let gh' = HM.lookup "blob" fixmeAttr
-
-      -- FIXME: define-fallback-action
-      gh <- ContT $ maybe1 gh' none
-
-      let cmd = [qc|git {gd} cat-file blob {pretty gh}|] :: String
-
-      let start = fromMaybe 0 fixmeStart & fromIntegral  & (\x -> x - before) & max 0
-      let bbefore = if start > before then before  + 1 else 1
-      let origLen = maybe  0 fromIntegral fixmeEnd - maybe 0 fromIntegral fixmeStart & max 1
-      let lno   = max 1 $ origLen + after + before
-
-      let dict = [ (mkId k, mkStr @C   v) | (k,v) <- HM.toList fixmeAttr ]
-                 <>
-                 [ (mkId (FixmeAttrName "before"), mkStr @C (FixmeAttrVal $ Text.pack $ show bbefore))
-                 ]
-
-      debug (pretty cmd)
-
-      w <- gitRunCommand cmd
-            <&> either (LBS8.pack . show) id
-            <&> LBS8.lines
-            <&> drop start
-            <&> take lno
-
-      liftIO $ action  dict (LBS8.unlines w)
-
-
-delete :: FixmePerks m => Text -> FixmeM m ()
-delete txt = do
-  acts <- asks fixmeEnvUpdateActions >>= readTVarIO
-  hashes <- selectFixmeHashes txt
-  for_ hashes $ \ha -> do
-    insertFixmeDelStaged ha
-
-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)
-    lift $ insertFixmeModStaged ha (fromString a) (fromString b)
-

fixme-new/lib/Fixme/Scan.hs

@@ -1,5 +1,5 @@
 {-# Language MultiWayIf #-}
-module Fixme.Scan (scanBlob,scanMagic) where
+module Fixme.Scan (scanBlob,scanMagic,updateScanMagic) where
 
 import Fixme.Prelude hiding (indent)
 import Fixme.Types
@@ -57,16 +57,23 @@ scanMagic :: FixmePerks m => FixmeM m HashRef
 scanMagic = do
   env <- ask
   w <- atomically do
-         tagz <- fixmeEnvTags env         & readTVar
+         tagz <- fixmeEnvTags env          & readTVar
-         co   <- fixmeEnvDefComments  env & readTVar
+         co   <- fixmeEnvDefComments  env  & readTVar
          fco  <- fixmeEnvFileComments env  & readTVar
          m    <- fixmeEnvFileMask env      & readTVar
+         e    <- fixmeEnvFileExclude env   & readTVar
          a    <- fixmeEnvAttribs env       & readTVar
          v    <- fixmeEnvAttribValues env  & readTVar
 
-         pure $ serialise (tagz, co, fco, m, a, v)
+         pure $ serialise (tagz, co, fco, m, e, a, v)
   pure $ HashRef $ hashObject w
 
+updateScanMagic :: (FixmePerks m) => FixmeM m ()
+updateScanMagic = do
+  t <- asks fixmeEnvScanMagic
+  magic <- scanMagic
+  atomically $ writeTVar t (Just magic)
+
 scanBlob :: forall m . FixmePerks m
          => Maybe FilePath   -- ^ filename to detect type
          -> ByteString       -- ^ content

fixme-new/lib/Fixme/Scan/Git/Local.hs

@@ -115,27 +115,6 @@ listCommits = do
 
     spec = sq <> delims " \t"
 
-
-listRefs :: FixmePerks m => Bool -> FixmeM m [(GitHash, GitRef)]
-listRefs every = do
-  gd <- fixmeGetGitDirCLIOpt
-  gitRunCommand [qc|git {gd} show-ref --dereference|]
-    <&> fromRight mempty
-    <&> fmap LBS8.words . LBS8.lines
-    <&> mapMaybe
-          (\case
-             [h,b] -> (,) <$> fromStringMay @GitHash (LBS8.unpack h) <*> pure (GitRef (LBS8.toStrict b))
-             _     -> Nothing
-          )
-    >>= filterM filt
-
-  where
-    filt _ | every = pure True
-
-    filt (h,_) = do
-      done <- withState $ isProcessed $ ViaSerialise h
-      pure (not done)
-
 listBlobs :: (FixmePerks m, MonadReader FixmeEnv m) => GitHash -> m [(FilePath,GitHash)]
 listBlobs co = do
   gd <- fixmeGetGitDirCLIOpt
@@ -166,60 +145,6 @@ filterBlobs xs = do
   pat <- asks fixmeEnvFileMask >>= readTVarIO <&> fmap (True,)
   filterBlobs0 pat xs
 
-
-scanGitLogLocal :: FixmePerks m
-                => FilePath
-                -> ( CompactStorage HbSync -> FixmeM m () )
-                -> FixmeM m ()
-scanGitLogLocal refMask play = do
-  warn $ red "scanGitLogLocal" <+> pretty refMask
-
-  (t,refs) <- timeItT $ listRefs False
-
-  let hashes = fmap fst refs
-
-  warn $ yellow "listRefs in" <+> pretty (realToFrac t :: Fixed E6)
-
-  let pat = [(True, refMask)]
-
-  -- FIXME: use-cache-to-skip-already-processed-tips
-  logz <- withState do
-      S.toList_ $ for_ hashes $ \h -> do
-          done <- lift $ isProcessed (ViaSerialise h)
-          unless done do
-            blobs <- lift $ lift $ (listBlobs h >>= filterBlobs0 pat)
-            when (List.null blobs) do
-              lift $ insertProcessed (ViaSerialise h)
-            for_ blobs $ \(_,b) -> do
-              S.yield (h,b)
-
-  warn $ yellow "STEP 3" <+> "for each tree   --- find log"
-
-  warn $ vcat (fmap pretty logz)
-
-  warn $ yellow "STEP 4" <+> "for each log    --- scan log"
-
-  withState $ transactional do
-
-    flip runContT pure do
-      for_ logz $ \(commitHash, h) -> callCC \shit -> do
-          warn $ blue "SCAN BLOB" <+> pretty h
-          tmp <- ContT $ bracket (liftIO (emptySystemTempFile "fixme-log")) rm
-          blob <- lift $ lift $ gitCatBlob h
-          liftIO (LBS8.writeFile tmp blob)
-
-          esto <- lift $ try @_ @CompactStorageOpenError $ compactStorageOpen @HbSync readonly tmp
-
-          -- skip even problematic commit
-          lift $ insertProcessed (ViaSerialise commitHash)
-
-          either (const $ warn $ "skip malformed/unknown log" <+> pretty h) (const none) esto
-          sto <- either (const $ shit ()) pure esto
-
-          lift $ lift $ play sto
-
-          compactStorageClose sto
-
 listRelevantBlobs :: FixmePerks m
                   => FixmeM m [(FilePath, GitHash)]
 listRelevantBlobs =  do
@@ -265,219 +190,6 @@ listFixmies = do
 
   pure mempty
 
-scanGitLocal :: FixmePerks m
-             => [ScanGitArgs]
-             -> Maybe FilePath
-             -> FixmeM m ()
-scanGitLocal args p =  do
-
-  env <- ask
-
-  flip runContT pure do
-
-    (dbFn, _) <- ContT $ withSystemTempFile "fixme-db" . curry
-
-    tempDb <- newDBPipeEnv dbPipeOptsDef dbFn
-
-    withDB tempDb do
-      ddl [qc| create table co
-               ( cohash text not null
-               , ts   int null
-               , primary key (cohash)
-               )
-             |]
-
-      ddl [qc| create table coattr
-               ( cohash text not null
-               , name   text not null
-               , value  text not null
-               , primary key (cohash,name)
-               )
-             |]
-
-      ddl [qc| create table blob
-               ( hash   text not null
-               , cohash text not null
-               , path   text not null
-               , primary key (hash,cohash,path)
-               )
-             |]
-
-      -- update_ [qc|ATTACH DATABASE '{dbpath}' as fixme|]
-
-    let onlyNewCommits xs
-            | ScanAllCommits `elem` args = pure xs
-            | otherwise = lift $ filterM (newCommit . view _1) xs
-
-    co <- lift listCommits >>= onlyNewCommits
-
-    lift do
-      withDB tempDb $ transactional do
-        for_ co $ \(commit, attr) -> do
-
-          debug $ "commit" <+> pretty commit
-
-          blobs <- lift $ listBlobs commit >>= withFixmeEnv env . filterBlobs
-
-          let ts = HM.lookup "commit-time" attr
-                     >>= readMay @Word64 . Text.unpack . coerce
-
-          insert [qc|
-              insert into co (cohash,ts) values (?,?) on conflict (cohash) do nothing
-              |] (commit,ts)
-
-          for_ (HM.toList attr) $ \(a,b) -> do
-            insert [qc|
-                insert into coattr(cohash,name,value) values(?,?,?)
-                on conflict (cohash,name) do nothing
-                |] (commit,a,b)
-
-          for_ blobs $ \(fp,h) -> do
-            insert [qc| insert into blob (hash,cohash,path)
-                        values (?,?,?)
-                        on conflict (hash,cohash,path) do nothing
-                      |] (h,commit,fp)
-
-
-    blobs <- withDB tempDb  do
-                select_ @_ @(GitHash, FilePath) [qc|select distinct hash, path from blob order by path|]
-
-    when ( PrintBlobs `elem` args ) do
-        for_ blobs $ \(h,fp) -> do
-          notice $ pretty h <+> pretty fp
-
-    callCC \fucked -> do
-
-      gitCat <- ContT $ bracket startGitCatFile (hClose . getStdin)
-
-      let ssin   = getStdin gitCat
-      let ssout  = getStdout gitCat
-
-      liftIO $ IO.hSetBuffering ssin LineBuffering
-
-      for_ blobs $ \(h,fp) ->  callCC \next -> do
-
-        seen <-  lift (withState $ selectObjectHash h) <&> isJust
-
-        when seen do
-          trace $ red "ALREADY SEEN BLOB" <+> pretty h
-          next ()
-
-        liftIO $ IO.hPrint ssin (pretty h) >> IO.hFlush ssin
-        prefix <- liftIO (BS.hGetLine ssout) <&> BS.words
-
-        case prefix of
-          [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
-                      let q = [qc|
-
-            WITH CommitAttributes AS (
-              SELECT co.cohash, co.ts, coattr.name, coattr.value
-              FROM co
-              JOIN coattr ON co.cohash = coattr.cohash
-            ),
-            MinCommitTimes AS (
-              SELECT blob.hash, MIN(co.ts) as mintime
-              FROM blob
-              JOIN co ON blob.cohash = co.cohash
-              WHERE co.ts IS NOT NULL
-              GROUP BY blob.hash
-            ),
-            RelevantCommits AS (
-              SELECT blob.hash, blob.cohash, blob.path
-              FROM blob
-              JOIN MinCommitTimes ON blob.hash = MinCommitTimes.hash
-              JOIN co ON blob.cohash = co.cohash AND co.ts = MinCommitTimes.mintime
-            )
-            SELECT CommitAttributes.name, CommitAttributes.value
-            FROM RelevantCommits
-            JOIN CommitAttributes ON RelevantCommits.cohash = CommitAttributes.cohash
-            WHERE RelevantCommits.hash = ?
-                      |]
-
-                      what <- select @(FixmeAttrName,FixmeAttrVal) q (Only h)
-                                <&> HM.fromList
-                                <&> (<> HM.fromList [ ("blob",fromString $ show (pretty h))
-                                                    , ("file",fromString fp)
-                                                    ])
-
-                      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 <> lno)) f
-
-
-            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
-
-            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 ksh = hashObject @HbSync (serialise ks) & pretty & show & Text.pack & FixmeAttrVal
-                            let kh = HM.singleton "fixme-key" ksh
-                            let kv = HM.singleton "fixme-key-string" (FixmeAttrVal ks) <> kh
-                            pure $ over (field @"fixmeAttr") (<> kv) fx
-
-            when ( PrintFixme `elem` args ) do
-              for_ fixmies $ \fixme -> do
-                notice $ pretty fixme
-
-            when ( ScanRunDry `elem` args ) $ fucked ()
-
-            debug $ "actually-import-fixmies" <+> pretty h
-
-            lift $ withFixmeEnv env $ withState $ transactional do
-              insertBlob h
-              for_ fixmies insertFixme
-
-          _ -> fucked ()
-
-      unless ( ScanRunDry `elem` args ) do
-        lift runLogActions
-
-      lift $ withFixmeEnv env $ withState $ transactional do
-        for_ co $ \w -> do
-          insertCommit (view _1 w)
-
 
 gitListStage :: (FixmePerks m)
              => FixmeM m [Either (FilePath, GitHash) (FilePath, GitHash)]
@@ -602,16 +314,6 @@ gitExtractFileMetaData fns = do
 
   pure $ HM.fromList [ (view _1 w, view _3 w) | w <- rich ]
 
--- TODO: move-outta-here
-runLogActions :: FixmePerks m => FixmeM m ()
-runLogActions = do
-  debug $ yellow "runLogActions"
-  actions <- asks fixmeEnvReadLogActions >>= readTVarIO
-
-  for_ actions $ \(ReadLogAction a) -> do
-    liftIO (a (List noContext []))
-
-  updateIndexes
 
 data GitBlobInfo = GitBlobInfo FilePath GitHash
                    deriving stock (Eq,Ord,Data,Generic,Show)

fixme-new/lib/Fixme/State.hs

@@ -3,30 +3,10 @@
 module Fixme.State
   ( evolve
   , withState
-  , insertFixme
-  , selectFixmeThin
-  , selectFixmeHash
-  , selectFixmeHashes
-  , selectFixme
-  , deleteFixme
-  , updateFixme
-  , insertCommit
-  , insertBlob
-  , selectObjectHash
-  , newCommit
   , cleanupDatabase
-  , updateIndexes
+  , insertFixme
-  , insertFixmeDelStaged
+  , insertScanned
-  , insertFixmeModStaged
+  , selectIsAlreadyScanned
-  , selectStageModified
-  , selectStageDeleted
-  , selectStage
-  , cleanStage
-  , insertProcessed
-  , isProcessed
-  , selectProcessed
-  , checkFixmeExists
-  , listAllFixmeHashes
   , HasPredicate(..)
   , SelectPredicate(..)
   ) where
@@ -57,6 +37,8 @@ import Control.Monad.Trans.Maybe
 import Data.Coerce
 import Data.Fixed
 import Data.Word (Word64)
+import System.Directory (getModificationTime)
+import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)
 import System.TimeIt
 
 -- TODO: runPipe-omitted
@@ -123,235 +105,20 @@ withState what = do
 createTables :: FixmePerks m => DBPipeM m ()
 createTables = do
 
-  -- тут все таблицы будут называться с префиксом
-  -- fixme, что бы может быть можно было встроить
-  -- в другую бд, если вдруг понадобится
 
-  ddl [qc|
+  ddl [qc| create table if not exists scanned
-        create table if not exists fixmegitobject
+           ( hash text not null primary key )
-          ( hash text not null
-          , type text null
-          , primary key (hash)
-          )
-      |]
-
-  ddl [qc|
-        create table if not exists fixme
-          ( id    text not null
-          , ts    integer
-          , fixme blob not null
-          , primary key (id)
-          )
-      |]
-
-  ddl [qc|
-        create table if not exists fixmedeleted
-          ( id      text not null
-          , ts      integer not null
-          , deleted bool not null
-          , primary key (id,ts)
-          )
-      |]
-
-  ddl [qc|
-        create table if not exists fixmerel
-          ( origin  text not null
-          , related text not null
-          , ts      integer not null
-          , reason  text not null
-          , primary key (origin,related,ts)
-          )
-      |]
-
-  ddl [qc|
-        create table if not exists fixmeattr
-          ( fixme   text not null
-          , ts      integer null
-          , name    text not null
-          , value   text
-          , primary key (fixme,ts,name)
-          )
-      |]
-
-  ddl [qc| drop view if exists fixmeattrview |]
-
-  let commits = [qc|name in ('commit','committer','committer-name','committer-email','commit-time')|] :: Text
-
-  ddl [qc|
-    create view fixmeattrview as
-      with ranked1 as (
-        select
-          fixme,
-          name,
-          value,
-          row_number() over (partition by fixme, name order by ts desc nulls first) as rn
-        from fixmeattr
-        where not ({commits})
-      )
-      , ranked2 as (
-        select
-          fixme,
-          name,
-          value,
-          row_number() over (partition by fixme, name order by ts asc nulls last) as rn
-        from fixmeattr
-        where ({commits})
-      )
-
-      select distinct fixme,name,value
-      from
-      (
-        select
-          fixme,
-          name,
-          value
-        from ranked1
-        where rn = 1
-
-        union
-
-        select
-          fixme,
-          name,
-          value
-        from ranked2
-        where rn = 1
-      )
-    |]
-
-  ddl [qc|drop view if exists fixmeactualview|]
-
-  ddl [qc|
-    create view fixmeactualview as
-    with a1 as (
-      select
-        a.fixme,
-        f.ts,
-        a.name,
-        a.value
-      from
-        fixmeattrview a
-        join fixme f on a.fixme = f.id
-      where
-        a.name = 'fixme-key'
-        and not exists (select null from fixmedeleted d where d.id = f.id)
-    ),
-    rn AS (
-      select
-        f.id,
-        f.ts,
-        a.value AS fixmekey,
-        row_number() over (partition by a.value order by f.ts desc) as rn
-      from
-        fixme f
-        join a1 a on f.id = a.fixme and a.name = 'fixme-key'
-    )
-    select id as fixme, fixmekey, ts from rn
-      where rn = 1
-      and not exists (
-      select null
-        from fixmeattr a
-             join fixmedeleted d on d.id = a.fixme
-        where a.name = 'fixme-key'
-              and a.value = rn.fixmekey
-      )
-
-    |]
-
-
-  ddl [qc|
-        create table if not exists fixmeactual
-          ( fixme   text not null
-          , primary key (fixme)
-          )
-      |]
-
-  ddl [qc|
-        create table if not exists fixmejson
-          ( fixme     text not null
-          , fixmekey  text
-          , json      blob
-          , primary key (fixme)
-          )
-      |]
-
-  ddl [qc|
-        create index if not exists idx_fixmekey ON fixmejson(fixmekey)
-      |]
-
-  ddl [qc| create table if not exists fixmestagedel
-           ( hash text    not null primary key
-           , ts   integer not null
-           )
          |]
 
-  ddl [qc| create table if not exists fixmestagemod
+  ddl [qc| create table if not exists object
-           ( hash   text    not null
+           ( o   text    not null
-           , ts     integer not null
+           , w   integer not null
-           , attr   text    not null
+           , k   text    not null
-           , value  text
+           , v   blob    not null
-           , primary key (hash,attr)
+           , primary key (o,k)
            )
          |]
 
-  ddl [qc| create table if not exists fixmeprocessed
-           ( hash   text  not null
-           , primary key (hash)
-           )
-         |]
-
--- .fixme-new/state.db
--- and not exists (select null from fixmedeleted d where a.fixme = id limit 1)
-
-insertCommit :: FixmePerks m => GitHash -> DBPipeM m ()
-insertCommit gh = do
-  insert [qc|
-    insert into fixmegitobject (hash,type) values(?,'commit')
-    on conflict (hash) do nothing
-            |] (Only gh)
-
-insertBlob :: FixmePerks m => GitHash -> DBPipeM m ()
-insertBlob gh = do
-  insert [qc|
-    insert into fixmegitobject (hash,type) values(?,'blob')
-    on conflict (hash) do nothing
-            |] (Only gh)
-
-selectObjectHash :: FixmePerks m => GitHash -> DBPipeM m (Maybe GitHash)
-selectObjectHash gh = do
-  select [qc|select hash from fixmegitobject where hash = ?|] (Only gh)
-    <&> fmap fromOnly . listToMaybe
-
-newCommit :: (FixmePerks m, MonadReader FixmeEnv m) => GitHash -> m Bool
-newCommit gh = isNothing <$> withState (selectObjectHash gh)
-
-insertFixme :: FixmePerks m => Fixme -> DBPipeM m ()
-insertFixme fx@Fixme{..} = do
-  let fixme = serialise fx
-  let fxId = hashObject @HbSync fixme & HashRef
-  insert [qc|insert into fixme (id, ts, fixme) values (?,?,?)
-             on conflict(id) do nothing
-            |] (fxId, fixmeTs, fixme)
-
-  for_ (HM.toList fixmeAttr) $ \(n,v) -> do
-    insert [qc|
-      insert into fixmeattr(fixme,ts,name,value)
-      values (?,?,?,?)
-      on conflict (fixme,ts,name) do update set value = excluded.value
-              |] (fxId, fixmeTs, n, v)
-
-    insert [qc|
-      insert into fixmeattr(fixme,ts,name,value)
-      values (?,?,?,?)
-      on conflict (fixme,ts,name) do update set value = excluded.value
-              |] (fxId, fixmeTs, "fixme-tag", fixmeTag)
-
-    insert [qc|
-      insert into fixmeattr(fixme,ts,name,value)
-      values (?,?,?,?)
-      on conflict (fixme,ts,name) do update set value = excluded.value
-              |] (fxId, fixmeTs, "fixme-title", fixmeTitle)
-
 
 data SelectPredicate =
     All
@@ -410,50 +177,6 @@ instance IsContext c => HasPredicate [Syntax c] where
 {- HLINT ignore "Functor law" -}
 {- HLINT ignore "Eta reduce" -}
 
-selectFixmeHash :: (FixmePerks m) => Text -> FixmeM m (Maybe Text)
-selectFixmeHash what = listToMaybe <$> selectFixmeHashes what
-
-selectFixmeHashes :: (FixmePerks m) => Text -> FixmeM m [Text]
-selectFixmeHashes what = withState do
-  let w = what <> "%"
-  select @(Only Text)
-            [qc| select fixme
-                 from fixmejson
-                 where json_extract(json,'$."fixme-key"') like ?
-                 union
-                 select id
-                 from fixme
-                 where id like ?
-            |] (w,w)
-         <&> fmap fromOnly
-
-selectFixme :: FixmePerks m => Text -> FixmeM m (Maybe Fixme)
-selectFixme txt = do
-
-  attrs <- selectFixmeThin (FixmeHashExactly txt)
-             <&> fmap coerce . headMay
-             <&> fromMaybe mempty
-
-  runMaybeT do
-
-    lift (withState $ select [qc|select fixme from fixme where id = ? limit 1|] (Only txt))
-      <&> listToMaybe . fmap fromOnly
-      >>= toMPlus
-      <&> (deserialiseOrFail @Fixme)
-      >>= toMPlus
-      <&> over (field @"fixmeAttr") (<> attrs)
-
-
-listAllFixmeHashes :: (FixmePerks m, MonadReader FixmeEnv m) => m (HashSet HashRef)
-listAllFixmeHashes = withState do
-  select_ @_ @(Only HashRef) [qc|select id from fixme|]
-    <&> HS.fromList . fmap fromOnly
-
-checkFixmeExists :: FixmePerks m => HashRef -> FixmeM m Bool
-checkFixmeExists what = withState do
-  select @(Only (Maybe Int)) [qc|select 1 from fixme where id = ? limit 1|] (Only what)
-    <&> not . List.null
-
 data Bound = forall a . (ToField a, Show a) => Bound a
 
 instance ToField Bound where
@@ -497,215 +220,70 @@ genPredQ tbl what = go what
       Ignored -> ("false", mempty)
 
 
-updateFixmeJson :: FixmePerks m =>  DBPipeM m ()
-updateFixmeJson = do
-
-  update_ [qc|
-
-    insert into fixmejson (fixme,fixmekey,json)
-      with json as  (
-        select
-            a.fixme as fixme,
-            cast(json_set(json_group_object(a.name,a.value), '$."fixme-hash"', f.fixme) as blob) as json
-
-        from
-          fixmeattrview a join fixmeactual f on f.fixme = a.fixme
-
-        group by a.fixme
-      )
-
-      select
-          fixme
-        , json_extract(json, '$."fixme-key"') as fixmekey
-        , json
-         from json where true
-      on conflict (fixme) do update set json = excluded.json, fixmekey = excluded.fixmekey
-  |]
-
-
--- TODO: predicate-for-stage-toggle
-selectFixmeThin :: (FixmePerks m, HasPredicate a) => a -> FixmeM m [FixmeThin]
-selectFixmeThin a = withState do
-
-  let predic = genPredQ "blob" (predicate a)
-
-  let emptyObect = [q|'{}'|] :: String
-
-  let sql = [qc|
-
-with s1 as (
-  select  m.hash as hash
-        , cast(json_group_object(m.attr,m.value) as blob) as json
-  from fixmestagemod m
-  where not exists (select null from fixmestagedel d where d.hash = m.hash)
-),
-
-s2 as
-  ( select  cast(json_patch(j.json, coalesce(s.json,{emptyObect})) as blob) as blob, j.fixme as fixme
-
-    from
-     fixmejson j join fixmeactual f on f.fixme = j.fixme
-                join fixme f0 on f0.id = f.fixme
-                left join s1 s on s.hash = j.fixme
-  )
-
-select s2.blob from s2
-
-where
-
-  (
-  {fst predic}
-  )
-
-order by json_extract(blob, '$.commit-time'), json_extract(blob, '$.title')
-
-  |]
-
-  trace $ red "selectFixmeThin" <> line <> pretty sql
-
-  (t,r) <- timeItT $ select sql (snd predic) <&> mapMaybe (Aeson.decode @FixmeThin . fromOnly)
-
-  trace $ yellow "selectFixmeThin" <> line
-            <> pretty sql <> line
-            <> pretty (length r) <+> "rows" <> line
-            <> pretty "elapsed" <+> pretty (realToFrac t :: Fixed E6)
-
-  pure r
-
 cleanupDatabase :: (FixmePerks m, MonadReader FixmeEnv m) => m ()
 cleanupDatabase = do
   warn $ red "cleanupDatabase"
   withState $ transactional do
-    update_ [qc|delete from fixme|]
+    update_ [qc|delete from object|]
-    update_ [qc|delete from fixmeattr|]
+    update_ [qc|delete from scanned|]
-    update_ [qc|delete from fixmegitobject|]
+
-    update_ [qc|delete from fixmedeleted|]
+scannedKey :: (FixmePerks m, MonadReader FixmeEnv m) => Fixme -> m HashRef
-    update_ [qc|delete from fixmerel|]
+scannedKey fme = do
-    update_ [qc|delete from fixmeactual|]
+  magic <- asks fixmeEnvScanMagic >>= readTVarIO
-    update_ [qc|delete from fixmejson|]
+  let file = fixmeAttr fme & HM.lookup "file"
-    update_ [qc|delete from fixmestagedel|]
+  let w  = fixmeTs fme
-    update_ [qc|delete from fixmestagemod|]
+  pure $ hashObject @HbSync ( serialise (magic,w,file) ) & HashRef
-
+
-
+scannedKeyForFile :: (FixmePerks m, MonadReader FixmeEnv m) => FilePath-> m HashRef
-insertFixmeModStaged :: (FixmePerks m,MonadReader FixmeEnv m)
+scannedKeyForFile  file = do
-                     => Text
+  dir <- fixmeWorkDir
-                     -> FixmeAttrName
+  magic <- asks fixmeEnvScanMagic >>= readTVarIO
-                     -> FixmeAttrVal
+  let fn = dir </> file
-                     -> m ()
+  w <- liftIO $ getModificationTime fn <&> round . utcTimeToPOSIXSeconds
-insertFixmeModStaged hash k v = withState do
+  pure $ hashObject @HbSync ( serialise (magic,w,file) ) & HashRef
-  ts <- getEpoch
+
-  insert [qc| insert into fixmestagemod (hash,ts,attr,value) values(?,?,?,?)
+selectIsAlreadyScanned :: (FixmePerks m, MonadReader FixmeEnv m) => FilePath -> m Bool
-              on conflict (hash,attr)
+selectIsAlreadyScanned file = withState do
-                 do update set hash  = excluded.hash
+  k <- lift $ scannedKeyForFile file
-                             , ts    = excluded.ts
+  what <- select @(Only Int) [qc|select 1 from scanned where hash = ? limit 1|] (Only k)
-                             , attr  = excluded.attr
+  pure $ not $ List.null what
-                             , value = excluded.value
+
-            |] (hash,ts,k,v)
+insertScanned :: (FixmePerks m, MonadReader FixmeEnv m) => FilePath -> DBPipeM m ()
-
+insertScanned file = do
-
+  k <- lift $ scannedKeyForFile file
-insertFixmeDelStaged :: (FixmePerks m,MonadReader FixmeEnv m) => Text -> m ()
+  insert [qc| insert into scanned (hash)
-insertFixmeDelStaged hash = withState do
+              values(?)
-  ts <- getEpoch
+              on conflict (hash) do nothing|]
-  insert [qc| insert into fixmestagedel (hash,ts) values(?,?)
+         (Only k)
-              on conflict (hash)
+
-                 do update set hash = excluded.hash
+insertFixme :: (FixmePerks m, MonadReader FixmeEnv m) => Fixme -> DBPipeM m ()
-                  , ts = excluded.ts
+insertFixme fme = do
-            |] (hash,ts)
+
-
+  void $ runMaybeT do
-
+
-type StageModRow = (HashRef,Word64,Text,Text)
+    o   <- fixmeKey fme & toMPlus
-
+    w   <-  fixmeTs fme & toMPlus
-selectStageModified :: (FixmePerks m,MonadReader FixmeEnv m) => m [CompactAction]
+    let attrs   = fixmeAttr fme
-selectStageModified = withState do
+    let txt = fixmePlain fme & Text.unlines . fmap coerce
-  what <- select_ @_ @StageModRow [qc|select hash,ts,attr,value from fixmestagemod|]
+
-  for what $ \(h,t,k,v) -> do
+    let sql = [qc|
-    pure $ Modified t h (FixmeAttrName k) (FixmeAttrVal v)
+      insert into object (o, w, k, v)
-
+      values (?, ?, ?, ?)
-selectStageDeleted :: (FixmePerks m,MonadReader FixmeEnv m) => m [CompactAction]
+      on conflict (o, k)
-selectStageDeleted = withState do
+      do update set
-  what <- select_ @_ @(HashRef,Word64) [qc|select hash,ts from fixmestagedel|]
+        v = case
-  for what $ \(h,t) -> do
+              when excluded.w > object.w and (excluded.v <> object.v) then excluded.v
-    pure $ Deleted t h
+              else object.v
-
+            end,
-selectStage :: (FixmePerks m,MonadReader FixmeEnv m) => m [CompactAction]
+        w = case
-selectStage = do
+              when excluded.w > object.w and (excluded.v <> object.v) then excluded.v
-  a <- selectStageModified
+              else object.w
-  b <- selectStageDeleted
+            end
-  pure (a<>b)
+      |]
-
+
-cleanStage :: (FixmePerks m,MonadReader FixmeEnv m) => m ()
+    for_ (HM.toList attrs) $ \(k,v) -> do
-cleanStage = withState do
+      lift $ insert sql (o,w,k,v)
-  transactional do
+
-    update_ [qc|delete from fixmestagedel|]
+    lift $ insert sql (o,w,"fixme-text",txt)
-    update_ [qc|delete from fixmestagemod|]
-
-deleteFixme :: (FixmePerks m,MonadReader FixmeEnv m) => Text -> m ()
-deleteFixme hash = withState do
-  trace $ red "deleteFixme" <+> pretty hash
-
-  here <- select [qc| select true
-                      from fixmedeleted
-                      where deleted and id = ?
-                      order by ts desc
-                      limit 1
-                     |] (Only hash) <&> isJust . listToMaybe . fmap (fromOnly @Bool)
-
-  unless here do
-    insert [qc| insert into fixmedeleted (id,ts,deleted)
-                values (?,(strftime('%s', 'now')),true)
-                on conflict(id,ts) do nothing
-              |] (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|]
-  update_ [qc|
-    insert into fixmeactual
-      select distinct fixme from fixmeactualview
-    |]
-  updateFixmeJson
-  -- FIXME: delete-table-grows
-  --   надо добавлять статус в fixmedeleted
-  --   только если он отличается от последнего
-  --   известного статуса
-  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 ()
-insertProcessed what = do
-  insert [qc| insert into fixmeprocessed (hash) values(?)
-              on conflict (hash) do nothing
-            |] (Only (show $ pretty $ hashObject @HbSync what))
-
-
-isProcessed :: (FixmePerks m, MonadReader FixmeEnv m, Hashed HbSync w)
-             => w
-             -> DBPipeM m Bool
-isProcessed what = do
-  let k = show $ pretty $ hashObject @HbSync what
-  select @(Only (Maybe Int)) [qc| select null from fixmeprocessed where hash = ? limit 1 |] (Only k)
-   <&> isJust . listToMaybe
-
-selectProcessed :: (FixmePerks m, MonadReader FixmeEnv m)
-                 => m [HashRef]
-selectProcessed = withState do
-  select_ [qc|select hash from fixmeprocessed|]
-    <&> fmap fromOnly
 
 

fixme-new/lib/Fixme/Types.hs

@@ -126,7 +126,7 @@ newtype FixmeTimestamp = FixmeTimestamp Word64
 
 
 newtype FixmeKey  = FixmeKey Text
-                    deriving newtype (Eq,Ord,Show,ToField,FromField)
+                    deriving newtype (Eq,Ord,Show,ToField,FromField,Pretty)
                     deriving stock (Data,Generic)
 
 newtype FixmeOffset = FixmeOffset Word32
@@ -281,12 +281,14 @@ data FixmeEnv =
   , fixmeEnvDb             :: TVar (Maybe DBPipeEnv)
   , fixmeEnvGitDir         :: TVar (Maybe FilePath)
   , fixmeEnvFileMask       :: TVar [FilePattern]
+  , fixmeEnvFileExclude    :: TVar [FilePattern]
   , fixmeEnvTags           :: TVar (HashSet FixmeTag)
   , fixmeEnvAttribs        :: TVar (HashSet FixmeAttrName)
   , fixmeEnvAttribValues   :: TVar (HashMap FixmeAttrName (HashSet FixmeAttrVal))
   , fixmeEnvDefComments    :: TVar (HashSet Text)
   , fixmeEnvFileComments   :: TVar (HashMap FilePath (HashSet Text))
   , fixmeEnvGitScanDays    :: TVar (Maybe Integer)
+  , fixmeEnvScanMagic      :: TVar (Maybe HashRef)
   , fixmeEnvUpdateActions  :: TVar [UpdateAction]
   , fixmeEnvReadLogActions :: TVar [ReadLogAction]
   , fixmeEnvCatAction      :: TVar CatAction
@@ -345,8 +347,10 @@ fixmeEnvBare =
     <*>  newTVarIO mempty
     <*>  newTVarIO mempty
     <*>  newTVarIO mempty
+    <*>  newTVarIO mempty
     <*>  newTVarIO defCommentMap
     <*>  newTVarIO Nothing
+    <*>  newTVarIO mzero
     <*>  newTVarIO mempty
     <*>  newTVarIO mempty
     <*>  newTVarIO (CatAction $ \_ _ -> pure ())
@@ -631,7 +635,7 @@ fixmeAttrNonEmpty a b = case (coerce a :: Text, coerce b :: Text) of
   (_,_) -> b
 
 fixmeDerivedFields :: Fixme -> Fixme
-fixmeDerivedFields fx = fx <> fxCo <> tag <> fxLno <> fxMisc
+fixmeDerivedFields fx = fx <> fxKey <> fxCo <> tag <> fxLno <> fxMisc
   where
     email = HM.lookup "commiter-email" (fixmeAttr fx)
               & maybe mempty (\x -> " <" <> x <> ">")
@@ -641,6 +645,10 @@ fixmeDerivedFields fx = fx <> fxCo <> tag <> fxLno <> fxMisc
 
     tag = mempty { fixmeAttr = HM.singleton "fixme-tag" (FixmeAttrVal (coerce $ fixmeTag fx))  }
 
+    key = maybe mempty (  HM.singleton "fixme-key" . FixmeAttrVal . coerce) (fixmeKey fx)
+
+    fxKey = mempty { fixmeAttr = key }
+
     lno = succ <$> fixmeStart fx <&> FixmeAttrVal . fromString . show
 
     fxLno = mempty { fixmeAttr = maybe mempty (HM.singleton "line") lno }

flake.lock

@@ -193,11 +193,11 @@
         "rev": "5a55c22750589b357e50b759d2a754df058446d6",
         "revCount": 40,
         "type": "git",
-        "url": "http://git.hbs2.net/GmcLB9gEPT4tbx9eyQiECwsu8oPyEh6qKEpQDtyBWVPA"
+        "url": "https://git.hbs2.net/GmcLB9gEPT4tbx9eyQiECwsu8oPyEh6qKEpQDtyBWVPA"
       },
       "original": {
         "type": "git",
-        "url": "http://git.hbs2.net/GmcLB9gEPT4tbx9eyQiECwsu8oPyEh6qKEpQDtyBWVPA"
+        "url": "https://git.hbs2.net/GmcLB9gEPT4tbx9eyQiECwsu8oPyEh6qKEpQDtyBWVPA"
       }
     },
     "fuzzy_2": {

flake.nix

@@ -24,7 +24,7 @@ inputs = {
     lsm.url = "git+https://git.hbs2.net/5BCaH95cWsVKBmWaDNLWQr2umxzzT5kqRRKNTm2J15Ls";
     lsm.inputs.nixpkgs.follows = "nixpkgs";
 
-    fuzzy.url = "git+http://git.hbs2.net/GmcLB9gEPT4tbx9eyQiECwsu8oPyEh6qKEpQDtyBWVPA";
+    fuzzy.url = "git+https://git.hbs2.net/GmcLB9gEPT4tbx9eyQiECwsu8oPyEh6qKEpQDtyBWVPA";
     fuzzy.inputs.nixpkgs.follows = "nixpkgs";
 
     saltine = {
@@ -105,8 +105,6 @@ outputs = { self, nixpkgs, haskell-flake-utils, ... }@inputs:
 
    ];
 
-  shellWithHoogle = true;
-
    shell = {pkgs, ...}:
       pkgs.haskellPackages.shellFor {
         packages = _: pkgs.lib.attrsets.attrVals packageNames pkgs.haskellPackages;

hbs2-core/lib/HBS2/System/Dir.hs

@@ -57,6 +57,7 @@ touch what = do
 pwd :: MonadIO m => m FilePath
 pwd = liftIO D.getCurrentDirectory
 
+
 doesPathExist :: MonadIO m => FilePath -> m Bool
 doesPathExist = liftIO . D.doesPathExist