wip

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

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)
-
-
-

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
+

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

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

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 (?,?,?)

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)