From c0b7184dc747c16b3644478892f8a13e570f448f Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Thu, 29 Aug 2024 04:08:49 +0300 Subject: [PATCH] wip --- fixme-new/app/FixmeMain.hs | 2 +- fixme-new/lib/Fixme/Run.hs | 68 +++++++++++++++++--------- fixme-new/lib/Fixme/Run/Internal.hs | 70 +++++++++++++++++++++++++++ fixme-new/lib/Fixme/RunOld.hs | 37 +------------- fixme-new/lib/Fixme/Scan/Git/Local.hs | 45 +++++++++++++++++ fixme-new/lib/Fixme/State.hs | 1 + fixme-new/lib/Fixme/Types.hs | 3 ++ 7 files changed, 165 insertions(+), 61 deletions(-) diff --git a/fixme-new/app/FixmeMain.hs b/fixme-new/app/FixmeMain.hs index e1fe169b..cdcce401 100644 --- a/fixme-new/app/FixmeMain.hs +++ b/fixme-new/app/FixmeMain.hs @@ -63,7 +63,7 @@ main = do -- TODO: scan-all-sources -- for-source-from-con - runFixmeCLI (runTop =<< liftIO getArgs) + runFixmeCLI runCLI -- FIXME: test-fixme -- $workflow: wip diff --git a/fixme-new/lib/Fixme/Run.hs b/fixme-new/lib/Fixme/Run.hs index f4e0ce7d..75bfc5e2 100644 --- a/fixme-new/lib/Fixme/Run.hs +++ b/fixme-new/lib/Fixme/Run.hs @@ -40,6 +40,7 @@ import Text.InterpolatedString.Perl6 (qc) import Data.Coerce import Control.Monad.Identity import Lens.Micro.Platform +import System.Environment import System.Process.Typed import Control.Monad.Trans.Cont import Control.Monad.Trans.Maybe @@ -47,6 +48,7 @@ import System.IO.Temp as Temp import System.IO qualified as IO +{- HLINT Ignore "Functor law" -} runFixmeCLI :: FixmePerks m => FixmeM m a -> m a runFixmeCLI m = do @@ -128,14 +130,16 @@ readConfig = do pure $ mconcat w -runTop :: FixmePerks m => [String] -> FixmeM m () -runTop argz = do - +runCLI :: FixmePerks m => FixmeM m () +runCLI = do + argz <- liftIO getArgs forms <- parseTop (unlines $ unwords <$> splitForms argz) & either (error.show) pure - -- pure ((unlines . fmap unwords . splitForms) what) - -- >>= either (error.show) pure . parseTop + runTop forms + +runTop :: FixmePerks m => [Syntax C] -> FixmeM m () +runTop forms = do let dict = makeDict @C do @@ -219,6 +223,41 @@ runTop argz = 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 + + 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] -> do + lift $ importFromLog fn + + _ -> throwIO $ BadFormException @C nil + + entry $ bindMatch "fixme:list" $ nil_ $ const do + fme <- lift listFixmies + pure () + + entry $ bindMatch "fixme:scan-git-local" $ nil_ $ const do + lift $ scanGitLocal mempty Nothing + + entry $ bindMatch "git:blobs" $ \_ -> do + blobs <- lift listRelevantBlobs + + elems <- for blobs $ \(f,h) -> do + pure $ mkList @C [ mkStr f, mkSym ".", mkStr h ] + + pure $ mkList @C elems + entry $ bindMatch "init" $ nil_ $ const $ do lift init @@ -226,22 +265,3 @@ runTop argz = do run dict (conf <> forms) >>= eatNil display - -- notice $ red "re-implementing fixme-new" - -- read refchan - -- execute settings from refchan - -- read config - - - -- execute config - -- execute cli - pure () - -- sc <- readConfig - - -- let s0 = fmap (parseTop . unwords) (splitForms what) - -- & rights - -- & mconcat - - -- runForms (sc <> s0) - - - diff --git a/fixme-new/lib/Fixme/Run/Internal.hs b/fixme-new/lib/Fixme/Run/Internal.hs index 4b670f6f..296d4bf3 100644 --- a/fixme-new/lib/Fixme/Run/Internal.hs +++ b/fixme-new/lib/Fixme/Run/Internal.hs @@ -129,3 +129,73 @@ printEnv = do liftIO $ print $ parens ("define-macro" <+> pretty n <+> pretty syn) +exportToLog :: FixmePerks m => FilePath -> FixmeM m () +exportToLog fn = do + e <- getEpoch + warn $ red "EXPORT-FIXMIES" <+> pretty fn + sto <- compactStorageOpen @HbSync mempty fn + 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 + + for_ what $ \w -> 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 + put sto k (LBS.toStrict $ serialise w) + + Just (Right prev) | getSequence w > getSequence prev -> do + put sto k (LBS.toStrict $ serialise w) + + _ -> pure () + + compactStorageClose sto + + cleanStage + +importFromLog :: FixmePerks m => FilePath -> FixmeM m () +importFromLog fn = 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 + warn $ 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 + + for_ w $ \x -> do + liftIO $ print $ pretty x + -- runTop (mconcat w) + + unless (List.null toImport) do + updateIndexes + + compactStorageClose sto + diff --git a/fixme-new/lib/Fixme/RunOld.hs b/fixme-new/lib/Fixme/RunOld.hs index ed2e0888..0e60747b 100644 --- a/fixme-new/lib/Fixme/RunOld.hs +++ b/fixme-new/lib/Fixme/RunOld.hs @@ -296,41 +296,6 @@ modify_ txt a b = do ha <- toMPlus =<< lift (selectFixmeHash txt) lift $ insertFixmeModStaged ha (fromString a) (fromString b) -exportToLog :: FixmePerks m => FilePath -> FixmeM m () -exportToLog fn = do - e <- getEpoch - warn $ red "EXPORT-FIXMIES" <+> pretty fn - sto <- compactStorageOpen @HbSync mempty fn - 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 - - for_ what $ \w -> 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 - put sto k (LBS.toStrict $ serialise w) - - Just (Right prev) | getSequence w > getSequence prev -> do - put sto k (LBS.toStrict $ serialise w) - - _ -> pure () - - compactStorageClose sto - - cleanStage importFromLog :: FixmePerks m => CompactStorage HbSync -> FixmeM m () importFromLog sto = do @@ -356,7 +321,7 @@ importFromLog sto = do for_ (rights toImport) insertFixme let w = lefts toImport - runForms (mconcat w) + eval (mconcat w) unless (List.null toImport) do updateIndexes diff --git a/fixme-new/lib/Fixme/Scan/Git/Local.hs b/fixme-new/lib/Fixme/Scan/Git/Local.hs index 445f5369..05f6496b 100644 --- a/fixme-new/lib/Fixme/Scan/Git/Local.hs +++ b/fixme-new/lib/Fixme/Scan/Git/Local.hs @@ -220,6 +220,51 @@ scanGitLogLocal refMask play = do compactStorageClose sto +listRelevantBlobs :: FixmePerks m + => FixmeM m [(FilePath, GitHash)] +listRelevantBlobs = do + commits <- listCommits + S.toList_ $ do + for_ commits $ \(co, _) -> do + found <- lift $ listBlobs co >>= filterBlobs + S.each found + +listFixmies :: FixmePerks m + => FixmeM m [Fixme] +listFixmies = do + + flip runContT pure do + + blobs <- lift listRelevantBlobs + + gitCat <- ContT $ bracket startGitCatFile (hClose . getStdin) + + let ssin = getStdin gitCat + let ssout = getStdout gitCat + + liftIO $ IO.hSetBuffering ssin LineBuffering + + for_ blobs $ \(fp,h) -> do + 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) + + liftIO $ mapM_ (print . pretty) poor + + _ -> pure () + + + + pure mempty + scanGitLocal :: FixmePerks m => [ScanGitArgs] -> Maybe FilePath diff --git a/fixme-new/lib/Fixme/State.hs b/fixme-new/lib/Fixme/State.hs index a1e6a290..b88bb91d 100644 --- a/fixme-new/lib/Fixme/State.hs +++ b/fixme-new/lib/Fixme/State.hs @@ -327,6 +327,7 @@ newCommit gh = isNothing <$> withState (selectObjectHash gh) insertFixme :: FixmePerks m => Fixme -> DBPipeM m () insertFixme fx@Fixme{..} = do + notice $ red "insertFixme!!!" let fixme = serialise fx let fxId = hashObject @HbSync fixme & HashRef insert [qc|insert into fixme (id, ts, fixme) values (?,?,?) diff --git a/fixme-new/lib/Fixme/Types.hs b/fixme-new/lib/Fixme/Types.hs index 5df8b085..426873e6 100644 --- a/fixme-new/lib/Fixme/Types.hs +++ b/fixme-new/lib/Fixme/Types.hs @@ -182,6 +182,9 @@ instance MkKey (FromFixmeKey Fixme) where instance IsContext c => MkStr c GitHash where mkStr ha = mkStr (show $ pretty ha) +instance IsContext c => MkStr c GitRef where + mkStr ha = mkStr (show $ pretty ha) + instance IsContext c => MkStr c HashRef where mkStr ha = mkStr (show $ pretty ha)