hbs2/fixme-new/lib/Fixme/Scan.hs

{-# Language MultiWayIf #-}
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.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 SfEnv =
  SfEnv { lno :: Int
        , l0  :: Int
        , eln :: Int
        }
        deriving stock Generic


succEln :: SfEnv -> ByteString -> SfEnv
succEln f s | LBS8.null s = over (field @"eln") succ f
            | otherwise = set (field @"eln") 0 f

data Sx = S0 | Sf SfEnv

data S = S Sx [(Int,ByteString)]


data FixmePart = FixmePart Int FixmeWhat
                 deriving stock (Show,Data,Generic)

data FixmeWhat = FixmeHead Int Int Text Text
               | FixmeLine Text
                 deriving stock (Show,Data,Generic)

data P = P0 [FixmePart] | P1 Int Fixme [FixmePart]

scanBlob :: forall m . 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)
              <&> fmap LBS8.pack

  comments <- fixmeGetCommentsFor fpath
                <&> filter (not . LBS8.null) . fmap (LBS8.pack . Text.unpack)

  let ls = LBS8.lines lbs & zip [0..]

  parts <- S.toList_ do

      flip fix (S S0 ls) $ \next -> \case
        S S0 ((lno,x):xs) -> do

          (l,bs)  <- eatPrefix0 Nothing comments x

          let mtag = headMay [ t | t <- tagz, LBS8.isPrefixOf t bs ]

          case mtag of
            Nothing ->
              next (S S0 xs)

            Just tag -> do
              emitFixmeStart lno l tag (LBS8.drop (LBS8.length tag) bs)
              next (S (Sf (SfEnv lno l 0)) xs)

        S sf@(Sf env@(SfEnv{..})) (x : xs) -> do

          (li,bs)  <- eatPrefix0 (Just l0) comments (snd x)

          if | eln > 1 -> next (S S0 (x:xs))

             | li <= l0 && not (LBS8.null bs) -> next (S S0 (x:xs))

             | otherwise -> do
                emitFixmeLine (fst x) l0 bs
                next (S (Sf (succEln env bs)) xs)

        S _ [] -> pure ()

  -- debug $ vcat (fmap viaShow parts)

  S.toList_ do
    flip fix (P0 parts) $ \next -> \case

        (P0 (FixmePart l h@FixmeHead{} : rs)) -> do
          next (P1 l (fromHead h) rs)

        (P1 _ fx (FixmePart l h@FixmeHead{} : rs)) -> do
          emitFixme fx
          next (P1 l (fromHead h) 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
        (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
        dropEmpty = dropWhile $ \case
          FixmePlainLine "" -> True
          _                 -> False

    -- FIXME: jopakita
    fromHead = \case
      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 lno lvl tag rest))

    emitFixmeLine lno l0 restbs = do
      let rest = decodeUtf8With ignore  (LBS8.toStrict restbs) & Text.stripEnd
      S.yield (FixmePart lno (FixmeLine rest))

    eatPrefix0 lim' comments x = do
      over _2 LBS8.pack <$> do

        flip fix (0, LBS8.unpack x) $ \next w@(k, left) -> do

          let lim = fromMaybe (succ k) lim'

          if k > lim then
            pure (k, left)
          else
            case w of
              (n, ' '  : rest) -> next (n+1, if k == lim then ' ' : rest else rest)
              (n, '\t' : rest) -> next (n+8, if k == lim then '\t' : rest else rest)

              (n, rest) -> do
                let comm = headMay [ co | co <- comments, LBS8.isPrefixOf co (LBS8.pack rest) ]
                case comm of
                  Nothing -> pure (n, rest)
                  Just co -> next (n+1, drop (fromIntegral $ LBS8.length co) rest)