wip

fixme-new/lib/Fixme/Run.hs

@@ -72,11 +72,11 @@ pattern StringLike e <- (stringLike -> Just e)
 pattern StringLikeList :: forall {c} . [String] -> [Syntax c]
 pattern StringLikeList e <- (stringLikeList -> e)
 
-
 data ScanGitArgs =
     PrintBlobs
   | PrintFixme
   | ScanRunDry
+  | ScanAllCommits
   deriving stock (Eq,Ord,Show,Data,Generic)
 
 pattern ScanGitArgs :: forall {c} . ScanGitArgs -> Syntax c
@@ -87,6 +87,7 @@ scanGitArg = \case
   SymbolVal "print-blobs" -> Just PrintBlobs
   SymbolVal "print-fixme" -> Just PrintFixme
   SymbolVal "dry"         -> Just ScanRunDry
+  SymbolVal "all-commits" -> Just ScanAllCommits
   _ -> Nothing
 
 scanGitArgs :: [Syntax c] -> [ScanGitArgs]
@@ -277,14 +278,20 @@ scanGitLocal args p =  do
                )
              |]
 
-      update_ [qc|ATTACH DATABASE '{dbpath}' as fixme|]
+      -- update_ [qc|ATTACH DATABASE '{dbpath}' as fixme|]
 
-    co <- lift listCommits
+    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 <- listBlobs commit >>= withFixmeEnv env . filterBlobs
 
           let ts = HM.lookup "commit-time" attr
@@ -312,7 +319,7 @@ scanGitLocal args p =  do
 
     when ( PrintBlobs `elem` args ) do
         for_ blobs $ \(h,fp) -> do
-          liftIO $ print $ pretty h <+> pretty fp
+          notice $ pretty h <+> pretty fp
 
     callCC \fucked -> do
 
@@ -336,7 +343,6 @@ scanGitLocal args p =  do
 
             poor <- lift (Scan.scanBlob (Just fp) blob)
 
-
             rich <- withDB tempDb do
                       let q = [qc|
 
@@ -382,20 +388,21 @@ scanGitLocal args p =  do
 
             when ( PrintFixme `elem` args ) do
               for_ fixmies $ \fixme -> do
-                liftIO $ print $ pretty fixme
+                notice $ pretty fixme
 
             when ( ScanRunDry `elem` args ) $ fucked ()
 
             debug $ "actually-import-fixmies" <+> pretty h
 
             liftIO $ withFixmeEnv env $ withState $ transactional do
-              for_ fixmies $ \fixme@Fixme{..} -> do
+              for_ fixmies insertFixme
-                debug $ "fixme-ts:" <+> pretty fixmeTs
-                insertFixme fixme
 
           _ -> fucked ()
 
 
+      liftIO $ withFixmeEnv env $ withState $ transactional do
+        for_ co $ \w -> do
+          insertCommit (view _1 w)
 
 
 startGitCatFile ::  (FixmePerks m, MonadReader FixmeEnv m) => m (Process Handle Handle ())

fixme-new/lib/Fixme/State.hs

@@ -3,6 +3,9 @@ module Fixme.State
   ( evolve
   , withState
   , insertFixme
+  , insertCommit
+  , selectCommit
+  , newCommit
   ) where
 
 import Fixme.Prelude
@@ -15,6 +18,7 @@ import DBPipe.SQLite
 
 import Data.HashMap.Strict qualified as HM
 import Text.InterpolatedString.Perl6 (qc)
+import Data.Maybe
 
 instance ToField HashRef where
   toField x = toField $ show $ pretty x
@@ -49,7 +53,6 @@ createTables = do
   ddl [qc|
         create table if not exists fixmecommit
           ( hash text not null
-          , ts   int not null
           , primary key (hash)
           )
       |]
@@ -92,6 +95,22 @@ createTables = do
       where rn = 1;
     |]
 
+
+insertCommit :: FixmePerks m => GitHash -> DBPipeM m ()
+insertCommit gh = do
+  insert [qc|
+    insert into fixmecommit (hash) values(?)
+    on conflict (hash) do nothing
+            |] (Only gh)
+
+selectCommit :: FixmePerks m => GitHash -> DBPipeM m (Maybe GitHash)
+selectCommit gh = do
+  select [qc|select hash from fixmecommit where hash = ?|] (Only gh)
+    <&> fmap fromOnly . listToMaybe
+
+newCommit :: (FixmePerks m, MonadReader FixmeEnv m) => GitHash -> m Bool
+newCommit gh = isNothing <$> withState (selectCommit gh)
+
 insertFixme :: FixmePerks m => Fixme -> DBPipeM m ()
 insertFixme fx@Fixme{..} = do
   let fixme = serialise fx