diff --git a/fixme-new/fixme.cabal b/fixme-new/fixme.cabal index 526ef9e1..2926c386 100644 --- a/fixme-new/fixme.cabal +++ b/fixme-new/fixme.cabal @@ -83,6 +83,7 @@ common shared-properties , time , timeit , transformers + , typed-process , unordered-containers , unliftio diff --git a/fixme-new/lib/Fixme/Run.hs b/fixme-new/lib/Fixme/Run.hs index 8a11247d..283bc728 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 DBPipe.SQLite hiding (field) import Data.Config.Suckless import Data.Text.Fuzzy.Tokenize @@ -33,6 +33,7 @@ import Data.Word import Text.InterpolatedString.Perl6 (qc) import Data.Coerce import Control.Monad.Identity +import Data.Generics.Product.Fields (field) import Lens.Micro.Platform import System.Process.Typed import Control.Monad.Trans.Cont @@ -174,7 +175,7 @@ listCommits = do [co, n, e, t] -> do let gh = fromStringMay @GitHash (Text.unpack co) - let bag = [ ("commit-hash", co) + let bag = [ ("commit", co) , ("commit-time", t) , ("committer-name", n) , ("committer-email", e) @@ -301,7 +302,45 @@ scanGitLocal args p = do blob <- liftIO $ LBS8.hGet ssout len void $ liftIO $ BS.hGetLine ssout - fixmies <- lift (Scan.scanBlob (Just fp) blob) + poor <- lift (Scan.scanBlob (Just fp) blob) + + rich <- withDB tempDb do + let q = [qc| + + WITH CommitAttributes AS ( + SELECT co.cohash, co.ts, coattr.name, coattr.value + FROM co + JOIN coattr ON co.cohash = coattr.cohash + ), + MinCommitTimes AS ( + SELECT blob.hash, MIN(co.ts) as mintime + FROM blob + JOIN co ON blob.cohash = co.cohash + WHERE co.ts IS NOT NULL + GROUP BY blob.hash + ), + RelevantCommits AS ( + SELECT blob.hash, blob.cohash, blob.path + FROM blob + JOIN MinCommitTimes ON blob.hash = MinCommitTimes.hash + JOIN co ON blob.cohash = co.cohash AND co.ts = MinCommitTimes.mintime + ) + SELECT CommitAttributes.name, CommitAttributes.value + FROM RelevantCommits + JOIN CommitAttributes ON RelevantCommits.cohash = CommitAttributes.cohash + WHERE RelevantCommits.hash = ? + |] + + what <- select @(FixmeAttrName,FixmeAttrVal) q (Only h) + <&> HM.fromList + <&> (<> HM.fromList [ ("blob",fromString $ show (pretty h)) + , ("file",fromString fp) + ]) + + for poor $ \f -> do + pure $ over (field @"fixmeAttr") (<> what) f + + let fixmies = rich when ( PrintFixme `elem` args ) do for_ fixmies $ \fixme -> do diff --git a/fixme-new/lib/Fixme/Scan.hs b/fixme-new/lib/Fixme/Scan.hs index a1636cac..78bf545f 100644 --- a/fixme-new/lib/Fixme/Scan.hs +++ b/fixme-new/lib/Fixme/Scan.hs @@ -43,11 +43,11 @@ data S = S Sx [(Int,ByteString)] data FixmePart = FixmePart Int FixmeWhat deriving stock (Show,Data,Generic) -data FixmeWhat = FixmeHead Int Text Text +data FixmeWhat = FixmeHead Int Int Text Text | FixmeLine Text deriving stock (Show,Data,Generic) -data P = P0 [FixmePart] | P1 Fixme [FixmePart] +data P = P0 [FixmePart] | P1 Int Fixme [FixmePart] scanBlob :: forall m . FixmePerks m => Maybe FilePath -- ^ filename to detect type @@ -94,7 +94,7 @@ scanBlob fpath lbs = do | li <= l0 && not (LBS8.null bs) -> next (S S0 (x:xs)) | otherwise -> do - emitFixmeLine lno l0 bs + emitFixmeLine (fst x) l0 bs next (S (Sf (succEln env bs)) xs) S _ [] -> pure () @@ -104,22 +104,26 @@ scanBlob fpath lbs = do S.toList_ do flip fix (P0 parts) $ \next -> \case - (P0 (FixmePart _ h@FixmeHead{} : rs)) -> do - next (P1 (fromHead h) rs) + (P0 (FixmePart l h@FixmeHead{} : rs)) -> do + next (P1 l (fromHead h) rs) - (P1 fx (FixmePart _ h@FixmeHead{} : rs)) -> do + (P1 _ fx (FixmePart l h@FixmeHead{} : rs)) -> do emitFixme fx - next (P1 (fromHead h) rs) + next (P1 l (fromHead h) rs) - (P1 fx (FixmePart _ (FixmeLine what) : rs)) -> do - next (P1 (over (field @"fixmePlain") (<> [FixmePlainLine what]) fx) rs) + (P1 w fx (FixmePart lno (FixmeLine what) : rs)) -> do + next (P1 lno (setLno lno $ over (field @"fixmePlain") (<> [FixmePlainLine what]) fx) rs) - (P1 fx []) -> emitFixme fx + (P1 _ fx []) -> emitFixme fx (P0 ( _ : rs ) ) -> next (P0 rs) (P0 []) -> pure () where + setLno lno fx@Fixme{} = do + let lno1 = Just (FixmeOffset (fromIntegral lno)) + set (field @"fixmeEnd") lno1 fx + emitFixme e = do S.yield $ over (field @"fixmePlain") dropEmpty e where @@ -129,13 +133,22 @@ scanBlob fpath lbs = do -- FIXME: jopakita fromHead = \case - FixmeHead _ tag title -> Fixme (FixmeTag tag) (FixmeTitle title) Nothing mempty mempty Nothing - _ -> Fixme mempty mempty Nothing mempty mempty Nothing + FixmeHead lno _ tag title -> + Fixme (FixmeTag tag) + (FixmeTitle title) + Nothing + (Just (FixmeOffset (fromIntegral lno))) + Nothing + mempty + mempty + Nothing + + _ -> Fixme mempty mempty Nothing Nothing Nothing mempty mempty Nothing emitFixmeStart lno lvl tagbs restbs = do let tag = decodeUtf8With ignore (LBS8.toStrict tagbs) & Text.strip let rest = decodeUtf8With ignore (LBS8.toStrict restbs) & Text.strip - S.yield (FixmePart lno (FixmeHead lvl tag rest)) + S.yield (FixmePart lno (FixmeHead lno lvl tag rest)) emitFixmeLine lno l0 restbs = do let rest = decodeUtf8With ignore (LBS8.toStrict restbs) & Text.stripEnd diff --git a/fixme-new/lib/Fixme/Types.hs b/fixme-new/lib/Fixme/Types.hs index 342f5cab..58659187 100644 --- a/fixme-new/lib/Fixme/Types.hs +++ b/fixme-new/lib/Fixme/Types.hs @@ -9,7 +9,7 @@ import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict qualified as HM import Data.HashSet (HashSet) import Data.HashSet qualified as HS -import Data.Word (Word64) +import Data.Word (Word64,Word32) import Data.Maybe import Data.Coerce import System.FilePath @@ -53,14 +53,22 @@ newtype FixmeTimestamp = FixmeTimestamp Word64 deriving newtype (Eq,Ord,Show,Num,ToField,FromField) deriving stock (Data,Generic) + +newtype FixmeOffset = FixmeOffset Word32 + deriving newtype (Eq,Ord,Show,Num,ToField,FromField) + deriving stock (Data,Generic) + + data Fixme = Fixme - { fixmeTag :: FixmeTag - , fixmeTitle :: FixmeTitle - , fixmeTs :: Maybe FixmeTimestamp - , fixmePlain :: [FixmePlainLine] - , fixmeAttr :: HashMap FixmeAttrName FixmeAttrVal - , fixmeSource :: Maybe FixmeSource + { fixmeTag :: FixmeTag + , fixmeTitle :: FixmeTitle + , fixmeTs :: Maybe FixmeTimestamp + , fixmeStart :: Maybe FixmeOffset + , fixmeEnd :: Maybe FixmeOffset + , fixmePlain :: [FixmePlainLine] + , fixmeAttr :: HashMap FixmeAttrName FixmeAttrVal + , fixmeSource :: Maybe FixmeSource } deriving stock (Show,Data,Generic) @@ -148,6 +156,7 @@ instance Serialise FixmePlainLine instance Serialise FixmeAttrName instance Serialise FixmeAttrVal instance Serialise FixmeTimestamp +instance Serialise FixmeOffset instance Serialise Fixme @@ -164,6 +173,14 @@ instance FromField GitHash where fromField = fmap fromString . fromField @String +instance Pretty FixmeOffset where + pretty = pretty . coerce @_ @Word32 + +instance Pretty FixmeAttrName where + pretty = pretty . coerce @_ @Text + +instance Pretty FixmeAttrVal where + pretty = pretty . coerce @_ @Text instance Pretty FixmeTitle where pretty = pretty . coerce @_ @Text @@ -177,8 +194,28 @@ instance Pretty FixmePlainLine where instance Pretty Fixme where pretty Fixme{..} = pretty fixmeTag <+> pretty fixmeTitle + <> fstart + <> fend + <> la <> lls + <> line where + + fstart = case fixmeStart of + Just s -> line <> pretty ([qc| $fixme-start: {show $ pretty s}|] :: String) + Nothing -> mempty + + fend = case fixmeEnd of + Just s -> line <> pretty ([qc| $fixme-end: {show $ pretty s}|] :: String) + Nothing -> mempty + + la | not (HM.null fixmeAttr) = do + let a = HM.toList fixmeAttr + let ss = [ [qc| ${show $ pretty n}: {show $ pretty v}|] | (n,v) <- a ] :: [String] + line <> vcat ( fmap pretty ss ) <> line + + | otherwise = mempty + lls | not (null fixmePlain) = line <> vcat (fmap pretty fixmePlain) | otherwise = mempty