diff --git a/fixme-new/lib/Fixme/Run.hs b/fixme-new/lib/Fixme/Run.hs index 895ea876..8a11247d 100644 --- a/fixme-new/lib/Fixme/Run.hs +++ b/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,46 +213,124 @@ 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 - listBlobs (fst c) >>= filterBlobs ) + lift do + 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 - liftIO $ print $ pretty h <+> pretty fp - - gitCat <- ContT $ bracket startGitCatFile (hClose . getStdin) - - let ssin = getStdin gitCat - let ssout = getStdout gitCat - - liftIO $ IO.hSetBuffering ssin LineBuffering + for_ blobs $ \(h,fp) -> do + liftIO $ print $ pretty h <+> pretty fp callCC \fucked -> do - when ( PrintFixme `elem` args ) do + gitCat <- ContT $ bracket startGitCatFile (hClose . getStdin) - for_ blobs $ \(fp,h) -> do - liftIO $ IO.hPrint ssin (pretty h) >> IO.hFlush ssin - prefix <- liftIO (BS.hGetLine ssout) <&> BS.words + let ssin = getStdin gitCat + let ssout = getStdout gitCat - 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 + liftIO $ IO.hSetBuffering ssin LineBuffering + for_ blobs $ \(h,fp) -> 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) + + when ( PrintFixme `elem` args ) do for_ fixmies $ \fixme -> do liftIO $ print $ pretty fixme - _ -> fucked () + _ -> 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 ()) diff --git a/fixme-new/lib/Fixme/Types.hs b/fixme-new/lib/Fixme/Types.hs index bb29668e..342f5cab 100644 --- a/fixme-new/lib/Fixme/Types.hs +++ b/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 diff --git a/hbs2/Main.hs b/hbs2/Main.hs index 4e894023..6217491c 100644 --- a/hbs2/Main.hs +++ b/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" )