wip

fixme-new/lib/Fixme/Run.hs

@@ -12,7 +12,7 @@ import Fixme.Scan as Scan
 import HBS2.Git.Local.CLI
 
 import HBS2.System.Dir
-
+import DBPipe.SQLite
 import Data.Config.Suckless
 import Data.Text.Fuzzy.Tokenize
 
@@ -29,6 +29,7 @@ import Data.Text qualified as Text
 import Data.Text.Encoding qualified as Text
 import Data.Text.Encoding (decodeUtf8With)
 import Data.Text.Encoding.Error (ignore)
+import Data.Word
 import Text.InterpolatedString.Perl6 (qc)
 import Data.Coerce
 import Control.Monad.Identity
@@ -212,17 +213,76 @@ filterBlobs xs = do
 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)
+               )
+             |]
+
+
     co <- lift listCommits
 
-    blobs <- lift $ mconcat <$> for co (\c -> do
+    lift do
-                            listBlobs (fst c) >>= filterBlobs )
+      withDB tempDb $ transactional do
+        for_ co $ \(commit, attr) -> do
+
+          blobs <- 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 $ \(fp,h) -> do
+        for_ blobs $ \(h,fp) -> do
           liftIO $ print $ pretty h <+> pretty fp
 
+    callCC \fucked -> do
+
       gitCat <- ContT $ bracket startGitCatFile (hClose . getStdin)
 
       let ssin   = getStdin gitCat
@@ -230,11 +290,7 @@ scanGitLocal args p =  do
 
       liftIO $ IO.hSetBuffering ssin LineBuffering
 
-    callCC \fucked -> do
+      for_ blobs $ \(h,fp) ->  do
-
-      when ( PrintFixme `elem` args ) do
-
-        for_ blobs $ \(fp,h) ->  do
         liftIO $ IO.hPrint ssin (pretty h) >> IO.hFlush ssin
         prefix <- liftIO (BS.hGetLine ssout) <&> BS.words
 
@@ -244,14 +300,37 @@ scanGitLocal args p =  do
             len <- ContT $ maybe1 mslen (pure ())
             blob <- liftIO $ LBS8.hGet ssout len
             void $ liftIO $ BS.hGetLine ssout
-              fixmies <- lift $ Scan.scanBlob (Just fp) blob
 
+            fixmies <- lift (Scan.scanBlob (Just fp) blob)
+
+            when ( PrintFixme `elem` args ) do
               for_ fixmies $ \fixme -> do
                 liftIO $ print $ pretty fixme
 
           _ -> fucked ()
 
-      debug $ red "NOW WHAT?"
+
+    --   when ( PrintFixme `elem` args ) do
+
+    --     for_ blobs $ \(fp,h) ->  do
+    --       liftIO $ IO.hPrint ssin (pretty h) >> IO.hFlush ssin
+    --       prefix <- liftIO (BS.hGetLine ssout) <&> BS.words
+
+    --       case prefix of
+    --         [_, "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
+
+    --           fixmies <- lift (Scan.scanBlob (Just fp) blob)
+
+    --           for_ fixmies $ \fixme -> do
+    --             liftIO $ print $ pretty fixme
+
+    --         _ -> fucked ()
+
+    --   debug $ red "NOW WHAT?"
 
 
 startGitCatFile ::  (FixmePerks m, MonadReader FixmeEnv m) => m (Process Handle Handle ())

fixme-new/lib/Fixme/Types.hs

@@ -1,6 +1,9 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
 module Fixme.Types where
 
 import Fixme.Prelude
+import DBPipe.SQLite
+import HBS2.Git.Local
 
 import Data.HashMap.Strict (HashMap)
 import Data.HashMap.Strict qualified as HM
@@ -25,30 +28,29 @@ data FixmeSource =
   deriving stock (Show,Data,Generic)
 
 newtype FixmeTag = FixmeTag { fromFixmeTag :: Text }
-                   deriving newtype (Eq,Ord,Show,IsString,Hashable,Semigroup,Monoid)
+                   deriving newtype (Eq,Ord,Show,IsString,Hashable,Semigroup,Monoid,ToField,FromField)
                    deriving stock (Data,Generic)
 
 newtype FixmeTitle = FixmeTitle { fromFixmeTitle :: Text }
-                     deriving newtype (Eq,Ord,Show,IsString,Semigroup,Monoid)
+                     deriving newtype (Eq,Ord,Show,IsString,Semigroup,Monoid,ToField,FromField)
                      deriving stock (Data,Generic)
 
 newtype FixmePlainLine = FixmePlainLine { fromFixmeText :: Text }
-                         deriving newtype (Eq,Ord,Show,IsString,Semigroup,Monoid)
+                         deriving newtype (Eq,Ord,Show,IsString,Semigroup,Monoid,ToField,FromField)
                          deriving stock (Data,Generic)
 
 
 newtype FixmeAttrName = FixmeAttrName { fromFixmeAttrName :: Text }
-                        deriving newtype (Eq,Ord,Show,IsString,Hashable)
+                        deriving newtype (Eq,Ord,Show,IsString,Hashable,ToField,FromField)
                         deriving stock (Data,Generic)
 
 
 newtype FixmeAttrVal = FixmeAttrVal { fromFixmeAttrVal :: Text }
-                        deriving newtype (Eq,Ord,Show,IsString)
+                        deriving newtype (Eq,Ord,Show,IsString,ToField,FromField)
                         deriving stock (Data,Generic)
 
-
 newtype FixmeTimestamp = FixmeTimestamp Word64
-                        deriving newtype (Eq,Ord,Show,Num)
+                        deriving newtype (Eq,Ord,Show,Num,ToField,FromField)
                         deriving stock (Data,Generic)
 
 data Fixme =
@@ -111,6 +113,9 @@ newtype FixmeM m a = FixmeM { fromFixmeM :: ReaderT FixmeEnv m a }
                                       , MonadReader FixmeEnv
                                       )
 
+withFixmeEnv :: FixmePerks m => FixmeEnv -> FixmeM m a -> m a
+withFixmeEnv env what = runReaderT ( fromFixmeM what) env
+
 runFixmeCLI :: FixmePerks m => FixmeM m a -> m a
 runFixmeCLI m = do
   env <- FixmeEnv Nothing
@@ -146,6 +151,20 @@ instance Serialise FixmeTimestamp
 instance Serialise Fixme
 
 
+instance ToField GitHash where
+  toField h = toField (show $ pretty h)
+
+instance ToField GitRef where
+  toField h = toField (show $ pretty h)
+
+instance FromField GitRef where
+  fromField = fmap fromString . fromField @String
+
+instance FromField GitHash where
+  fromField = fmap fromString . fromField @String
+
+
+
 instance Pretty FixmeTitle where
   pretty = pretty . coerce @_ @Text
 

hbs2/Main.hs

@@ -865,7 +865,7 @@ main = join . customExecParser (prefs showHelpOnError) $
         deepScan ScanDeep (const none) h (getBlock sto) $ \ha -> do
           print $ pretty ha
 
-    -- TODO: reflog-del-command-- TODO: reflog-del-command
+    -- TODO: reflog-del-command
     pDel = do
       o <- common
       recurse <- optional (flag' True ( short 'r' <> long "recursive" <> help "try to delete all blocks recursively" )