wip

fixme-new/lib/Fixme/Run.hs

@@ -32,7 +32,9 @@ import Data.Maybe
 import Data.HashSet qualified as HS
 import Data.HashMap.Strict (HashMap)
 import Data.HashMap.Strict qualified as HM
+import Data.HashSet (HashSet)
 import Data.Set qualified as Set
+import Data.Generics.Product.Fields (field)
 import Data.List qualified as List
 import Data.Text qualified as Text
 import Data.Text.IO qualified as Text
@@ -742,12 +744,6 @@ runForms ss = for_  ss $ \s -> do
       fxm <-  gitExtractFileMetaData fs <&> HM.toList
       liftIO $ print $ vcat (fmap (pretty.snd) fxm)
 
-    ListVal [SymbolVal "builtin:calc-line", LitIntVal off] -> do
-      prefix <- liftIO $ LBS8.getContents <&> LBS8.lines <&> drop (fromIntegral off)
-      liftIO $ mapM_ LBS8.putStrLn prefix
-      -- let lfn = List.find (=='\n') (LBS8.unpack prefix)
-      -- liftIO $ print $ pretty lfn
-
     ListVal [SymbolVal "builtin:extract-from-stage"] -> do
       env <- ask
       stage <- gitListStage
@@ -758,15 +754,19 @@ runForms ss = for_  ss $ \s -> do
 
       let fns = fmap fst blobs
 
-      meta <- gitExtractFileMetaData fns
+      -- TODO: extract-metadata-from-git-blame
+      --   subj
 
       for_ blobs $ \(fn, readBlob) -> do
         lbs <- readBlob
-
         fxs <- scanBlob (Just fn) lbs
-                 >>= \e -> for e $ \fx0 -> do
-                        let fxm = fromMaybe mempty $ HM.lookup fn meta
-                        pure (fxm <> fx0)
+                 >>= \e -> do
+                  for e $ \fx0 -> do
+                    let ls = fixmePlain fx0
+                    meta <- getMetaDataFromGitBlame fn fx0
+                    -- let fxm = fromMaybe mempty $ HM.lookup fn meta
+                    pure $ fixmeDerivedFields (fx0 <> mkFixmeFileName fn <> meta)
+                             & set (field @"fixmePlain") ls
 
         for_ fxs $ \fx -> do
           liftIO $ print (pretty fx)

fixme-new/lib/Fixme/Scan/Git/Local.hs

@@ -31,6 +31,7 @@ import Data.Maybe
 import Data.HashMap.Strict (HashMap)
 import Data.HashMap.Strict qualified as HM
 import Data.HashSet qualified as HS
+import Data.HashSet (HashSet)
 import Data.Text qualified as Text
 import Data.Text.Encoding (decodeUtf8With)
 import Data.Text.Encoding.Error (ignore)
@@ -71,6 +72,7 @@ scanGitArg = \case
 
 {- HLINT ignore "Functor law" -}
 
+
 listCommits :: FixmePerks m => FixmeM m [(GitHash, HashMap FixmeAttrName FixmeAttrVal)]
 listCommits = do
   gd <- fixmeGetGitDirCLIOpt
@@ -469,6 +471,45 @@ gitListStage = do
   pure (old1 <> new1)
 
 
+getMetaDataFromGitBlame :: FixmePerks m => FilePath -> Fixme -> FixmeM m Fixme
+getMetaDataFromGitBlame f fx0 = do
+  gd <- fixmeGetGitDirCLIOpt
+  fromMaybe mempty <$> runMaybeT do
+    l0 <- fixmeStart fx0 & toMPlus <&> fromIntegral <&> succ
+    let cmd = [qc|git {gd} blame {f} -L{l0},{l0} -t -l -p|]
+
+    s0 <- gitRunCommand cmd
+             <&> LBS8.unpack . fromRight mempty
+
+    s <- parseTop s0 & toMPlus
+
+    let ko = headMay (words <$> lines s0)
+                   >>= headMay
+                   >>= (\z -> do
+                         if z == "0000000000000000000000000000000000000000"
+                           then Nothing
+                           else Just z )
+                   >>= fromStringMay @GitHash
+
+    pieces <- for s $ \case
+      ListVal (SymbolVal "committer" : StringLikeList  w) | isJust ko -> do
+        let co = FixmeAttrVal $ fromString $ unwords w
+        pure $ mempty { fixmeAttr = HM.singleton "committer-name" co }
+
+      ListVal (SymbolVal "committer-mail" : StringLikeList  w) | isJust ko -> do
+        let co = FixmeAttrVal $ fromString $ unwords w
+        pure $ mempty { fixmeAttr = HM.singleton "committer-email" co }
+
+      ListVal [SymbolVal "committer-time", TimeStampLike t] | isJust ko  -> do
+        let ct = FixmeAttrVal $ fromString $ show t
+        pure $ mempty { fixmeAttr = HM.singleton "commit-time" ct, fixmeTs = Just t }
+
+      _ -> pure mempty
+
+    let coco = mempty { fixmeAttr = maybe mempty (HM.singleton "commit" . fromString . show . pretty) ko }
+
+    pure $ mconcat pieces <> coco
+
 gitExtractFileMetaData :: FixmePerks m => [FilePath] -> FixmeM m (HashMap FilePath Fixme)
 gitExtractFileMetaData fns = do
   -- FIXME: magic-number
@@ -527,6 +568,40 @@ runLogActions = do
 
   updateIndexes
 
+data GitBlobInfo = GitBlobInfo FilePath GitHash
+                   deriving stock (Eq,Ord,Data,Generic,Show)
+
+instance Hashable GitBlobInfo
+
+data GitIndexEntry =
+       GitCommit Word64 (HashSet GitBlobInfo)
+       deriving stock (Eq,Ord,Data,Generic,Show)
+
+instance Serialise GitBlobInfo
+instance Serialise GitIndexEntry
+
+listCommitForIndex :: forall m . (FixmePerks m, MonadReader FixmeEnv m) => ( (GitHash, GitIndexEntry) -> m ()) -> m ()
+listCommitForIndex fn = do
+
+  gd <- fixmeGetGitDirCLIOpt
+  let cmd = [qc|git {gd} log --all --format="%H %ct"|]
+
+  debug $ yellow "listCommits" <+> pretty cmd
+
+  s0 <- gitRunCommand cmd
+    <&> fromRight mempty
+    <&> fmap (words . LBS8.unpack) . LBS8.lines
+    <&> mapMaybe ( \case
+         [a,b] -> (,) <$> fromStringMay @GitHash a <*> makeIndexEntry0 a b
+         _     -> Nothing
+         )
+
+  for_ s0 $ \(h, GitCommit w _) -> do
+    blobz <- listBlobs h <&> HS.fromList . fmap ( uncurry GitBlobInfo  )
+    fn (h, GitCommit w blobz)
+
+  where
+    makeIndexEntry0 _ t = GitCommit <$> readMay t <*> pure mempty
 
 gitCatBlob :: (FixmePerks m, MonadReader FixmeEnv m) => GitHash -> m ByteString
 gitCatBlob h = do

fixme-new/lib/Fixme/Types.hs

@@ -150,7 +150,7 @@ newtype FixmeAttrName = FixmeAttrName { fromFixmeAttrName :: Text }
 
 
 newtype FixmeAttrVal = FixmeAttrVal { fromFixmeAttrVal :: Text }
-                        deriving newtype (Eq,Ord,Show,IsString,Hashable,ToField,FromField,ToJSON,FromJSON)
+                        deriving newtype (Eq,Ord,Show,IsString,Hashable,ToField,FromField,ToJSON,FromJSON,Semigroup,Monoid)
                         deriving stock (Data,Generic)
 
 newtype FixmeTimestamp = FixmeTimestamp Word64
@@ -186,6 +186,8 @@ instance Monoid Fixme where
 
 instance Semigroup Fixme where
   (<>) a b = b { fixmeTs  = fixmeTs b <|> fixmeTs a
+               , fixmeTitle = fixmeAttrNonEmpty (fixmeTitle a) (fixmeTitle b)
+               , fixmeTag   = fixmeAttrNonEmpty (fixmeTag a) (fixmeTag b)
                , fixmeStart = fixmeStart b <|> fixmeStart a
                , fixmeEnd = fixmeEnd b <|> fixmeEnd a
                , fixmePlain = fixmePlain b
@@ -596,3 +598,38 @@ instance Serialise a => Hashed HbSync (ViaSerialise a) where
   hashObject (ViaSerialise x) = hashObject (serialise x)
 
 
+fixmeTitleNonEmpty :: FixmeTitle -> FixmeTitle -> FixmeTitle
+fixmeTitleNonEmpty a b = case (coerce a :: Text, coerce b :: Text) of
+  (x,y) | Text.null x && not (Text.null y) -> FixmeTitle y
+  (x,y) | not (Text.null x) &&  Text.null y -> FixmeTitle x
+  (_,y) -> FixmeTitle y
+
+fixmeAttrNonEmpty :: Coercible a Text => a -> a -> a
+fixmeAttrNonEmpty a b = case (coerce a :: Text, coerce b :: Text) of
+  (x,y) | Text.null x && not (Text.null y) -> b
+  (x,y) | not (Text.null x) &&  Text.null y -> a
+  (_,_) -> b
+
+fixmeDerivedFields :: Fixme -> Fixme
+fixmeDerivedFields fx = fx <> fxCo <> tag <> fxLno
+  where
+    email = HM.lookup "commiter-email" (fixmeAttr fx)
+              & maybe mempty (\x -> " <" <> x <> ">")
+
+    comitter = HM.lookup "commiter-name" (fixmeAttr fx)
+                 <&> (<> email)
+
+    tag = mempty { fixmeAttr = HM.singleton "fixme-tag" (FixmeAttrVal (coerce $ fixmeTag fx))  }
+
+    lno = succ <$> fixmeStart fx <&> FixmeAttrVal . fromString . show
+
+    fxLno = mempty { fixmeAttr = maybe mempty (HM.singleton "line") lno }
+
+    fxCo =
+      maybe mempty (\c -> mempty { fixmeAttr = HM.singleton "committer" c }) comitter
+
+mkFixmeFileName :: FilePath -> Fixme
+mkFixmeFileName fp =
+  mempty { fixmeAttr = HM.singleton "file" (FixmeAttrVal (fromString fp)) }
+
+