voidlizard
/
hbs2
mirror of https://github.com/voidlizard/hbs2
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

wip

This commit is contained in:
Dmitry Zuikov 2024-05-11 13:14:51 +03:00
parent 45f525c756
commit 498ad63f63
4 changed files with 113 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
fixme-new/fixme.cabal
View File

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

45
fixme-new/lib/Fixme/Run.hs
View File

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

39
fixme-new/lib/Fixme/Scan.hs
View File

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

51
fixme-new/lib/Fixme/Types.hs
View File

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