diff --git a/fixme-new/fixme.cabal b/fixme-new/fixme.cabal index fac3bb36..e912f40a 100644 --- a/fixme-new/fixme.cabal +++ b/fixme-new/fixme.cabal @@ -103,6 +103,7 @@ library Fixme.Types Fixme.Prelude Fixme.State + Fixme.Scan Fixme.Scan.Git build-depends: base diff --git a/fixme-new/lib/Fixme/Scan.hs b/fixme-new/lib/Fixme/Scan.hs new file mode 100644 index 00000000..1111e505 --- /dev/null +++ b/fixme-new/lib/Fixme/Scan.hs @@ -0,0 +1,173 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} +module Fixme.Scan (scanBlob) where + +import Fixme.Prelude hiding (indent) +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 + +{- 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 S = S Sx E + deriving stock (Show) + +pattern CurrentChar :: Char -> S -> S +pattern CurrentChar c s <- s@(S _ ( currentChar -> Just c )) + +pattern EndOfLine :: S -> S +pattern EndOfLine s <- s@(S _ ( currentChar -> Nothing )) + +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 + +currentChunk :: E -> ByteString +currentChunk (E _ off (x:_)) = LBS8.drop off x +currentChunk _ = mempty + +indent :: E -> Int +indent (E n _ _) = n + +-- 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 + => Maybe FilePath -- ^ filename to detect type + -> ByteString -- ^ content + -> FixmeM m [Fixme] + +scanBlob fpath lbs = do + + tagz' <- asks fixmeEnvTags + >>= readTVarIO + <&> HS.toList + <&> fmap (Text.unpack . coerce) + <&> filter (not . null) + + let tagz = [ (head t, LBS8.pack t) | t <- tagz' ] & Map.fromList + + comments <- fixmeGetCommentsFor fpath + <&> filter (not . null) . fmap Text.unpack + + let co = Map.fromList [ (head s, LBS8.pack s) | s <- comments ] + + let ls = LBS8.lines lbs + + -- TODO: ASAP-no-comment-case + -- для текстовых файлов нет комментариев, + -- этот кейс тоже надо обработать (из S0!) + + flip fix (S S0 (E 0 0 ls)) $ \next -> \case + + EndOfInput{} -> pure () + + -- S0 + CurrentChar ' ' (S S0 e) -> do + next (S S0 (shiftI 1 $ move 1 $ e)) + + CurrentChar '\t' (S S0 e) -> do + next (S S0 (shiftI 8 $ move 1 $ e)) + + -- maybe-start-of-comment + 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 + 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 + next (S S0 (move 1 $ e)) + + -- Sc + + CurrentChar ' ' (S Sc e) -> do + next (S Scc (shiftI 1 $ move 1 $ e)) + + CurrentChar '\t' (S Sc e) -> do + next (S Scc (shiftI 8 $ move 1 $ e)) + + -- Scc + + CurrentChar ' ' (S Scc e) -> do + next (S Scc (shiftI 1 $ move 1 $ e)) + + CurrentChar '\t' (S Scc e) -> do + next (S Scc (shiftI 8 $ move 1 $ e)) + + CurrentChar c (S Scc e) | Map.member c tagz -> do + + let tag = Map.lookup c tagz & fromJust -- works, cause Map.member + + 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? ну чо нет-то + + -- Sf + -- жрём до + -- 1. Пока indent > indent (Sf ..) + + CurrentChar ' ' (S (Sf{}) e) -> do + next (S Scc (shiftI 1 $ move 1 $ e)) + + CurrentChar '\t' (S (Sf{}) e) -> do + next (S Scc (shiftI 8 $ move 1 $ e)) + + CurrentChar c (S (Sf{}) e) -> do + error "WTF?" + + -- в любом случае жрём строку, что бы это закончилось + EndOfLine (S _ e) -> do + next (S S0 (setI 0 $ dropLine $ e)) + + w -> error (show w) + + pure mempty + + diff --git a/fixme-new/lib/Fixme/Types.hs b/fixme-new/lib/Fixme/Types.hs index cae08751..d20b3cf1 100644 --- a/fixme-new/lib/Fixme/Types.hs +++ b/fixme-new/lib/Fixme/Types.hs @@ -79,8 +79,13 @@ data FixmeEnv = } -fixmeGetCommentsFor :: FixmePerks m => FilePath -> FixmeM m [Text] -fixmeGetCommentsFor fp = do +fixmeGetCommentsFor :: FixmePerks m => Maybe FilePath -> FixmeM m [Text] + +fixmeGetCommentsFor Nothing = do + asks fixmeEnvDefComments >>= readTVarIO + <&> HS.toList + +fixmeGetCommentsFor (Just fp) = do cof <- asks fixmeEnvFileComments >>= readTVarIO def <- asks fixmeEnvDefComments >>= readTVarIO