wip

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

fixme-new/fixme.cabal

@@ -70,6 +70,7 @@ common shared-properties
       , exceptions
       , filepath
       , filepattern
+      , generic-lens
       , interpolatedstring-perl6
       , memory
       , microlens-platform

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
+  what <- liftIO LBS8.getContents
-  pure ()
+  fixmies <- Scan.scanBlob Nothing what
+  liftIO $ print $ vcat (fmap pretty fixmies)
 
 printEnv :: FixmePerks m => FixmeM m ()
 printEnv = do

fixme-new/lib/Fixme/Scan.hs

@@ -1,5 +1,4 @@
-{-# LANGUAGE PatternSynonyms #-}
+{-# Language MultiWayIf #-}
-{-# LANGUAGE ViewPatterns #-}
 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 =
+data SfEnv =
-  E Int Int64 [ByteString]
+  SfEnv { lno :: Int
-  deriving stock (Show)
+        , l0  :: Int
+        , eln :: Int
+        }
 
-data S = S Sx E
+sfEnv0 = SfEnv 0 0 0
-         deriving stock (Show)
 
-pattern CurrentChar :: Char -> S -> S
+data Sx = S0 | Sf SfEnv
-pattern CurrentChar c s <- s@(S _ ( currentChar -> Just c ))
 
-pattern EndOfLine :: S -> S
+data S = S Sx [(Int,ByteString)]
-pattern EndOfLine s <- s@(S _ ( currentChar -> Nothing ))
 
-pattern EndOfInput :: S -> S
-pattern EndOfInput s <- s@(S _ (E _ _ []))
 
-currentChar :: E -> Maybe Char
+data FixmePart = FixmePart Int FixmeWhat
-currentChar = \case
+                 deriving stock (Show,Data,Generic)
-  (E _ n (x:_)) -> LBS8.indexMaybe x n
-  (E _ _ [])    -> Nothing
 
-currentChunk :: E -> ByteString
+data FixmeWhat = FixmeHead Int Text Text
-currentChunk (E _ off (x:_)) = LBS8.drop off x
+               | FixmeLine Text
-currentChunk _ = mempty
+                 deriving stock (Show,Data,Generic)
 
-indent :: E -> Int
+data P = P0 [FixmePart] | P1 Fixme [FixmePart]
-indent (E n _ _) = n
 
--- increase current indent level by i
+scanBlob :: forall m . FixmePerks m
-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
          => 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)
-
+              <&> fmap LBS8.pack
-  let tagz = [ (head t, LBS8.pack t) | t <- tagz' ] & Map.fromList
 
   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
+      flip fix (S S0 ls) $ \next -> \case
-  --   для текстовых файлов нет комментариев,
+        S S0 ((lno,x):xs) -> do
-  --   этот кейс тоже надо обработать (из S0!)
 
-  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
+          case mtag of
-    CurrentChar ' ' (S S0 e) -> do
+            Nothing ->
-      next (S S0 (shiftI 1 $ move 1 $ e))
+              next (S S0 xs)
 
-    CurrentChar '\t' (S S0 e) -> do
+            Just tag -> do
-      next (S S0 (shiftI 8 $ move 1 $ e))
+              emitFixmeStart lno l tag (LBS8.drop (LBS8.length tag) bs)
+              next (S (Sf (SfEnv lno l 0)) xs)
 
-    -- maybe-start-of-comment
+        S sf@(Sf (SfEnv{..})) (x : xs) -> do
-    CurrentChar c (S S0 e) | Map.member c co -> do
-      let comm = Map.lookup c co & fromMaybe (LBS8.singleton c)
 
-      if LBS8.isPrefixOf comm (currentChunk e) then
+          (li,bs)  <- eatPrefix comments (snd x)
-         next (S Sc (shiftI 1 $ move (max 1 (LBS8.length comm)) $ e))
-      else do
-         -- scanning-further
-         next (S S0 (move 1 $ e))
 
-    CurrentChar _ (S S0 e) -> do
+          if li <= l0 && not (LBS8.null bs) then do
-      next (S S0 (move 1 $ e))
+            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
+  debug $ vcat (fmap viaShow parts)
-      next (S Scc (shiftI 1 $ move 1 $ e))
 
-    CurrentChar '\t' (S Sc e) -> do
+  S.toList_ do
-      next (S Scc (shiftI 8 $ move 1 $ e))
+    flip fix (P0 parts) $ \next -> \case
 
-    -- Scc
+        (P0 (FixmePart _ h@FixmeHead{} : rs)) -> do
+          next (P1 (fromHead h) rs)
 
-    CurrentChar ' ' (S Scc e) -> do
+        (P1 fx (FixmePart _ h@FixmeHead{} : rs)) -> do
-      next (S Scc (shiftI 1 $ move 1 $ e))
+          emitFixme fx
+          next (P1 (fromHead h) rs)
 
-    CurrentChar '\t' (S Scc e) -> do
+        (P1 fx (FixmePart _ (FixmeLine what) : rs)) -> do
-      next (S Scc (shiftI 8 $ move 1 $ e))
+          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
+    emitFixme e = do
-         next (S (Sf (indent e) tag mempty) (move (max 1 (LBS8.length tag)) $ e))
+      S.yield $ over (field @"fixmePlain") dropEmpty e
-        -- это тег
+      where
-        -- переходим в обработку fixme
+        dropEmpty = dropWhile $ \case
-        -- запоминаем indent
+          FixmePlainLine "" -> True
-      else
+          _                 -> False
-         next (S Scc (shiftI 1 $ move 1 $ e))
-         -- это не тег, но и не пробел
-         -- едем дальше по коменту
-         -- двигаем ли indent? ну чо нет-то
 
-    -- Sf
+    -- FIXME: jopakita
-    -- жрём до
+    fromHead = \case
-    --  1. Пока indent > indent (Sf ..)
+      FixmeHead _ tag title -> Fixme (FixmeTag tag) (FixmeTitle title) Nothing mempty mempty Nothing
+      _ -> Fixme mempty mempty Nothing mempty mempty Nothing
 
-    CurrentChar ' ' (S (Sf{}) e) -> do
+    emitFixmeStart lno lvl tagbs restbs = do
-      next (S Scc (shiftI 1 $ move 1 $ e))
+      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
+    emitFixmeLine lno l0 restbs = do
-      next (S Scc (shiftI 8 $ move 1 $ e))
+      debug $ red "emitFixmeLine"
+      let rest = decodeUtf8With ignore  (LBS8.toStrict restbs) & Text.stripEnd
+      S.yield (FixmePart lno (FixmeLine rest))
 
-    CurrentChar c (S (Sf{}) e) -> do
+    eatPrefix comments x = do
-      error "WTF?"
+      -- дропаем пробелы или табы
+      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)
 

fixme-new/lib/Fixme/Types.hs

@@ -15,8 +15,7 @@ import System.FilePath
 data GitLocation =
   GitLocation
   { gitLocationHash   :: GitHash
-  , gitLocationOffset :: Integer
+  , gitLocationLine   :: Integer
-  , gitLocationLength :: 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)