From 60fde0e948ae51de03ce5066ee937d33fa52ab60 Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Fri, 10 May 2024 12:25:09 +0300 Subject: [PATCH] wip --- fixme-new/app/FixmeMain.hs | 2 +- fixme-new/fixme.cabal | 1 + fixme-new/lib/Fixme/Run.hs | 6 +- fixme-new/lib/Fixme/Scan.hs | 204 +++++++++++++++++------------------ fixme-new/lib/Fixme/Types.hs | 23 ++-- 5 files changed, 119 insertions(+), 117 deletions(-) diff --git a/fixme-new/app/FixmeMain.hs b/fixme-new/app/FixmeMain.hs index d5ee2e3d..656d269b 100644 --- a/fixme-new/app/FixmeMain.hs +++ b/fixme-new/app/FixmeMain.hs @@ -7,7 +7,7 @@ import System.Environment -- TODO: fixme-new -- после майских: -- 1. fixme переезжает в дерево hbs2, конкретно в hbs2-git --- +-- ?? -- 2. fixme преобразуется в утилиту для генерации отчётов по репозиторию git -- -- 3. fixme генерирует поток фактов про репозиторий git, включая записи todo/fixme diff --git a/fixme-new/fixme.cabal b/fixme-new/fixme.cabal index e912f40a..526ef9e1 100644 --- a/fixme-new/fixme.cabal +++ b/fixme-new/fixme.cabal @@ -70,6 +70,7 @@ common shared-properties , exceptions , filepath , filepattern + , generic-lens , interpolatedstring-perl6 , memory , microlens-platform diff --git a/fixme-new/lib/Fixme/Run.hs b/fixme-new/lib/Fixme/Run.hs index ac63a681..a5befddd 100644 --- a/fixme-new/lib/Fixme/Run.hs +++ b/fixme-new/lib/Fixme/Run.hs @@ -6,6 +6,7 @@ import Prelude hiding (init) import Fixme.Prelude hiding (indent) import Fixme.Types import Fixme.Scan.Git as Git +import Fixme.Scan as Scan import HBS2.Git.Local.CLI @@ -192,8 +193,9 @@ readUtf8 bs = LBS8.toStrict bs & Text.decodeUtf8 readFixmeStdin :: FixmePerks m => FixmeM m () readFixmeStdin = do - what <- liftIO LBS8.getContents <&> LBS8.lines - pure () + what <- liftIO LBS8.getContents + fixmies <- Scan.scanBlob Nothing what + liftIO $ print $ vcat (fmap pretty fixmies) printEnv :: FixmePerks m => FixmeM m () printEnv = do diff --git a/fixme-new/lib/Fixme/Scan.hs b/fixme-new/lib/Fixme/Scan.hs index 1111e505..fc0da407 100644 --- a/fixme-new/lib/Fixme/Scan.hs +++ b/fixme-new/lib/Fixme/Scan.hs @@ -1,5 +1,4 @@ -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE ViewPatterns #-} +{-# Language MultiWayIf #-} module Fixme.Scan (scanBlob) where import Fixme.Prelude hiding (indent) @@ -8,166 +7,157 @@ import Fixme.Types import Data.ByteString.Lazy.Char8 (ByteString) import Data.ByteString.Lazy.Char8 qualified as LBS8 import Data.Text qualified as Text - import Data.Text.Encoding (decodeUtf8With) import Data.Text.Encoding.Error (ignore) -import Data.Int -import Data.Map (Map) -import Data.Map qualified as Map import Data.Maybe import Data.HashSet qualified as HS import Data.Coerce +import GHC.Generics (Generic) +import Data.Generics.Product.Fields (field) +import Lens.Micro.Platform + +import Streaming.Prelude qualified as S + {- HLINT ignore "Functor law" -} -data Sx = S0 -- initial state - | Sc -- in-comment state - | Scc -- in-comment-after-space - | Sf Int ByteString ByteString -- fixme-found-at-indent - deriving stock (Show) -data E = - E Int Int64 [ByteString] - deriving stock (Show) +data SfEnv = + SfEnv { lno :: Int + , l0 :: Int + , eln :: Int + } -data S = S Sx E - deriving stock (Show) +sfEnv0 = SfEnv 0 0 0 -pattern CurrentChar :: Char -> S -> S -pattern CurrentChar c s <- s@(S _ ( currentChar -> Just c )) +data Sx = S0 | Sf SfEnv -pattern EndOfLine :: S -> S -pattern EndOfLine s <- s@(S _ ( currentChar -> Nothing )) +data S = S Sx [(Int,ByteString)] -pattern EndOfInput :: S -> S -pattern EndOfInput s <- s@(S _ (E _ _ [])) -currentChar :: E -> Maybe Char -currentChar = \case - (E _ n (x:_)) -> LBS8.indexMaybe x n - (E _ _ []) -> Nothing +data FixmePart = FixmePart Int FixmeWhat + deriving stock (Show,Data,Generic) -currentChunk :: E -> ByteString -currentChunk (E _ off (x:_)) = LBS8.drop off x -currentChunk _ = mempty +data FixmeWhat = FixmeHead Int Text Text + | FixmeLine Text + deriving stock (Show,Data,Generic) -indent :: E -> Int -indent (E n _ _) = n +data P = P0 [FixmePart] | P1 Fixme [FixmePart] --- increase current indent level by i -shiftI :: Int -> E -> E -shiftI i (E j o s) = E (i+j) o s - -setI :: Int -> E -> E -setI i (E _ o s) = E i o s - -move :: Int64 -> E -> E -move i (E x p s) = E x (p+i) s - -dropLine :: E -> E -dropLine (E x _ s) = E x 0 (drop 1 s) - -scanBlob :: FixmePerks m +scanBlob :: forall m . FixmePerks m => Maybe FilePath -- ^ filename to detect type -> ByteString -- ^ content -> FixmeM m [Fixme] scanBlob fpath lbs = do - tagz' <- asks fixmeEnvTags + tagz <- asks fixmeEnvTags >>= readTVarIO <&> HS.toList <&> fmap (Text.unpack . coerce) <&> filter (not . null) - - let tagz = [ (head t, LBS8.pack t) | t <- tagz' ] & Map.fromList + <&> fmap LBS8.pack comments <- fixmeGetCommentsFor fpath - <&> filter (not . null) . fmap Text.unpack + <&> filter (not . LBS8.null) . fmap (LBS8.pack . Text.unpack) - let co = Map.fromList [ (head s, LBS8.pack s) | s <- comments ] + let ls = LBS8.lines lbs & zip [0..] - let ls = LBS8.lines lbs + parts <- S.toList_ do - -- TODO: ASAP-no-comment-case - -- для текстовых файлов нет комментариев, - -- этот кейс тоже надо обработать (из S0!) + flip fix (S S0 ls) $ \next -> \case + S S0 ((lno,x):xs) -> do - flip fix (S S0 (E 0 0 ls)) $ \next -> \case + (l,bs) <- eatPrefix comments x - EndOfInput{} -> pure () + let mtag = headMay [ t | t <- tagz, LBS8.isPrefixOf t bs ] - -- S0 - CurrentChar ' ' (S S0 e) -> do - next (S S0 (shiftI 1 $ move 1 $ e)) + case mtag of + Nothing -> + next (S S0 xs) - CurrentChar '\t' (S S0 e) -> do - next (S S0 (shiftI 8 $ move 1 $ e)) + Just tag -> do + emitFixmeStart lno l tag (LBS8.drop (LBS8.length tag) bs) + next (S (Sf (SfEnv lno l 0)) xs) - -- maybe-start-of-comment - CurrentChar c (S S0 e) | Map.member c co -> do - let comm = Map.lookup c co & fromMaybe (LBS8.singleton c) + S sf@(Sf (SfEnv{..})) (x : xs) -> do - if LBS8.isPrefixOf comm (currentChunk e) then - next (S Sc (shiftI 1 $ move (max 1 (LBS8.length comm)) $ e)) - else do - -- scanning-further - next (S S0 (move 1 $ e)) + (li,bs) <- eatPrefix comments (snd x) - CurrentChar _ (S S0 e) -> do - next (S S0 (move 1 $ e)) + if li <= l0 && not (LBS8.null bs) then do + next (S S0 (x:xs)) + else do + emitFixmeLine lno l0 bs -- (snd x) + next (S sf xs) - -- Sc + S _ [] -> pure () - CurrentChar ' ' (S Sc e) -> do - next (S Scc (shiftI 1 $ move 1 $ e)) + debug $ vcat (fmap viaShow parts) - CurrentChar '\t' (S Sc e) -> do - next (S Scc (shiftI 8 $ move 1 $ e)) + S.toList_ do + flip fix (P0 parts) $ \next -> \case - -- Scc + (P0 (FixmePart _ h@FixmeHead{} : rs)) -> do + next (P1 (fromHead h) rs) - CurrentChar ' ' (S Scc e) -> do - next (S Scc (shiftI 1 $ move 1 $ e)) + (P1 fx (FixmePart _ h@FixmeHead{} : rs)) -> do + emitFixme fx + next (P1 (fromHead h) rs) - CurrentChar '\t' (S Scc e) -> do - next (S Scc (shiftI 8 $ move 1 $ e)) + (P1 fx (FixmePart _ (FixmeLine what) : rs)) -> do + next (P1 (over (field @"fixmePlain") (<> [FixmePlainLine what]) fx) rs) - CurrentChar c (S Scc e) | Map.member c tagz -> do + (P1 fx []) -> emitFixme fx + (P0 ( _ : rs ) ) -> next (P0 rs) + (P0 []) -> pure () - let tag = Map.lookup c tagz & fromJust -- works, cause Map.member + where - if LBS8.isPrefixOf tag (currentChunk e) then - next (S (Sf (indent e) tag mempty) (move (max 1 (LBS8.length tag)) $ e)) - -- это тег - -- переходим в обработку fixme - -- запоминаем indent - else - next (S Scc (shiftI 1 $ move 1 $ e)) - -- это не тег, но и не пробел - -- едем дальше по коменту - -- двигаем ли indent? ну чо нет-то + emitFixme e = do + S.yield $ over (field @"fixmePlain") dropEmpty e + where + dropEmpty = dropWhile $ \case + FixmePlainLine "" -> True + _ -> False - -- Sf - -- жрём до - -- 1. Пока indent > indent (Sf ..) + -- FIXME: jopakita + fromHead = \case + FixmeHead _ tag title -> Fixme (FixmeTag tag) (FixmeTitle title) Nothing mempty mempty Nothing + _ -> Fixme mempty mempty Nothing mempty mempty Nothing - CurrentChar ' ' (S (Sf{}) e) -> do - next (S Scc (shiftI 1 $ move 1 $ e)) + emitFixmeStart lno lvl tagbs restbs = do + debug $ red "emitFixmeStart" + 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)) - CurrentChar '\t' (S (Sf{}) e) -> do - next (S Scc (shiftI 8 $ move 1 $ e)) + emitFixmeLine lno l0 restbs = do + debug $ red "emitFixmeLine" + let rest = decodeUtf8With ignore (LBS8.toStrict restbs) & Text.stripEnd + S.yield (FixmePart lno (FixmeLine rest)) - CurrentChar c (S (Sf{}) e) -> do - error "WTF?" + eatPrefix comments x = do + -- дропаем пробелы или табы + let (pre1,s1) = LBS8.span (`elem` " \t") x - -- в любом случае жрём строку, что бы это закончилось - EndOfLine (S _ e) -> do - next (S S0 (setI 0 $ dropLine $ e)) + -- дропаем токен коммента + -- перебираем все коменты, пока не найдем первый + let comm = headMay [ co | co <- comments, LBS8.isPrefixOf co s1 ] - w -> error (show w) + let pre2 = pre1 <> fromMaybe mempty comm + let rest2 = LBS8.drop (maybe 0 LBS8.length comm) s1 - pure mempty + let (pre3,s2) = LBS8.span (`elem` " \t") rest2 + let pre = pre1 <> pre2 <> pre3 + + l <- for (LBS8.unpack pre) $ \case + ' ' -> pure 1 + '\t' -> pure 8 + _ -> pure 0 + + let level = sum l + maybe 0 (const 1) comm + + pure (level, s2) diff --git a/fixme-new/lib/Fixme/Types.hs b/fixme-new/lib/Fixme/Types.hs index d20b3cf1..dba3b73b 100644 --- a/fixme-new/lib/Fixme/Types.hs +++ b/fixme-new/lib/Fixme/Types.hs @@ -15,8 +15,7 @@ import System.FilePath data GitLocation = GitLocation { gitLocationHash :: GitHash - , gitLocationOffset :: Integer - , gitLocationLength :: Integer + , gitLocationLine :: Integer } deriving stock (Eq,Ord,Show,Data,Generic) @@ -25,15 +24,15 @@ data FixmeSource = deriving stock (Show,Data,Generic) newtype FixmeTag = FixmeTag { fromFixmeTag :: Text } - deriving newtype (Eq,Ord,Show,IsString,Hashable) + deriving newtype (Eq,Ord,Show,IsString,Hashable,Semigroup,Monoid) deriving stock (Data,Generic) newtype FixmeTitle = FixmeTitle { fromFixmeTitle :: Text } - deriving newtype (Eq,Ord,Show,IsString) + deriving newtype (Eq,Ord,Show,IsString,Semigroup,Monoid) deriving stock (Data,Generic) newtype FixmePlainLine = FixmePlainLine { fromFixmeText :: Text } - deriving newtype (Eq,Ord,Show,IsString) + deriving newtype (Eq,Ord,Show,IsString,Semigroup,Monoid) deriving stock (Data,Generic) @@ -48,14 +47,14 @@ newtype FixmeAttrVal = FixmeAttrVal { fromFixmeAttrVal :: Text } newtype FixmeTimestamp = FixmeTimestamp Word64 - deriving newtype (Eq,Ord,Show) + deriving newtype (Eq,Ord,Show,Num) deriving stock (Data,Generic) data Fixme = Fixme { fixmeTag :: FixmeTag , fixmeTitle :: FixmeTitle - , fixmeTs :: FixmeTimestamp + , fixmeTs :: Maybe FixmeTimestamp , fixmePlain :: [FixmePlainLine] , fixmeAttr :: HashMap FixmeAttrName FixmeAttrVal , fixmeSource :: Maybe FixmeSource @@ -144,6 +143,16 @@ instance Pretty FixmeTitle where instance Pretty FixmeTag where pretty = pretty . coerce @_ @Text +instance Pretty FixmePlainLine where + pretty = pretty . coerce @_ @Text + +instance Pretty Fixme where + pretty Fixme{..} = + pretty fixmeTag <+> pretty fixmeTitle + <> lls + where + lls | not (null fixmePlain) = line <> vcat (fmap pretty fixmePlain) + | otherwise = mempty defCommentMap :: HashMap FilePath (HashSet Text)