diff --git a/fixme-new/lib/Fixme/Run.hs b/fixme-new/lib/Fixme/Run.hs index d10859eb..6f8c4ced 100644 --- a/fixme-new/lib/Fixme/Run.hs +++ b/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) diff --git a/fixme-new/lib/Fixme/Scan/Git/Local.hs b/fixme-new/lib/Fixme/Scan/Git/Local.hs index 2c6c4250..445f5369 100644 --- a/fixme-new/lib/Fixme/Scan/Git/Local.hs +++ b/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 diff --git a/fixme-new/lib/Fixme/Types.hs b/fixme-new/lib/Fixme/Types.hs index 2872e2da..5f281c00 100644 --- a/fixme-new/lib/Fixme/Types.hs +++ b/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)) } + +