wip

fixme-new/fixme.cabal

@@ -83,6 +83,7 @@ common shared-properties
       , time
       , timeit
       , transformers
+
       , typed-process
       , unordered-containers
       , unliftio

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

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
+        (P0 (FixmePart l h@FixmeHead{} : rs)) -> do
-          next (P1 (fromHead h) rs)
+          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
+        (P1 w fx (FixmePart lno (FixmeLine what) : rs)) -> do
-          next (P1 (over (field @"fixmePlain") (<> [FixmePlainLine what]) fx) rs)
+          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
+      FixmeHead lno  _ tag title ->
-      _ -> Fixme mempty mempty Nothing mempty mempty Nothing
+          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

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,11 +53,19 @@ 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
+  , fixmeStart     :: Maybe FixmeOffset
+  , fixmeEnd       :: Maybe FixmeOffset
   , fixmePlain     :: [FixmePlainLine]
   , fixmeAttr      :: HashMap FixmeAttrName FixmeAttrVal
   , fixmeSource    :: Maybe FixmeSource
@@ -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