diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,18 @@ # Revision history for ghc-tags-pipes +## 0.2.0.1 -- 2026-10-23 + +## 0.2.0.0 -- 2026-10-22 + +- Recover streamed tags after malformed lines. Add `tagParserWithWarnings` to + report skipped records without stopping tag updates. + +- Add a complete streaming merge that removes duplicates from old and new tags, + retaining distinct tags with equal sorting keys. + +- Match complete module paths when merging streamed tags, preserving files with + matching filename or directory suffixes. + ## 0.1.1.0 -- 2023-05-01 * `GHC-9.6` support. diff --git a/ghc-tags-pipes.cabal b/ghc-tags-pipes.cabal --- a/ghc-tags-pipes.cabal +++ b/ghc-tags-pipes.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: ghc-tags-pipes -version: 0.1.1.0 +version: 0.2.0.1 synopsis: Streaming interface for ghc-tags-core description: Interface to stream tags using `pipes` library. homepage: https://github.com/coot/ghc-tags-plugin#readme @@ -9,7 +9,7 @@ license-file: LICENSE author: Marcin Szamotulski maintainer: coot@coot.me -copyright: (c) 2022, Marcin Szamotulski +copyright: (c) 2022-2026, Marcin Szamotulski category: Development build-type: Simple extra-doc-files: CHANGELOG.md @@ -19,27 +19,22 @@ ghc-options: -Wall -Wno-unticked-promoted-constructors -Wcompat - -- the following three warnings are enabled by -Wall in - -- ghc-9.2 - -Wno-incomplete-uni-patterns - -Wno-incomplete-record-updates -Wpartial-fields -Widentities -Wredundant-constraints - if impl(ghc >= 9) - ghc-options: -Wunused-packages + -Wunused-packages library import: warnings hs-source-dirs: lib exposed-modules: GhcTags.Stream - build-depends: attoparsec >=0.13.0.0, - base >=4.12.0.0 && <4.19, - bytestring >=0.10, - mtl, + build-depends: attoparsec >=0.13 && <0.15, + base >=4.12 && <4.23, + bytestring >=0.10 && <0.13, + mtl <2.4, pipes ^>=4.3, pipes-attoparsec ^>=0.6, pipes-bytestring ^>=2.1, - text >=1.2 && <2.1, - ghc-tags-core + text >=1.2 && <2.2, + ghc-tags-core ^>=1.0.0.0 default-language: Haskell2010 diff --git a/lib/GhcTags/Stream.hs b/lib/GhcTags/Stream.hs --- a/lib/GhcTags/Stream.hs +++ b/lib/GhcTags/Stream.hs @@ -10,21 +10,25 @@ -- module GhcTags.Stream ( tagParser + , tagParserWithWarnings + , ParsingError (..) + , combineTagsStream , combineTagsPipe , runCombineTagsPipe ) where -#if __GLASGOW_HASKELL__ >= 906 +#if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0) import Control.Monad.State.Strict #else import Control.Monad.State.Strict hiding (void) #endif +import Control.Exception (throwIO) import Data.ByteString (ByteString) import Data.Attoparsec.ByteString (Parser) -import qualified Data.ByteString as BS import Data.ByteString.Builder (Builder) import qualified Data.ByteString.Builder as BS -import Data.Functor (void, ($>)) +import Data.Foldable (traverse_) +import Data.Functor (($>)) import qualified Data.Text.Encoding as Text import System.IO @@ -32,12 +36,16 @@ import qualified Pipes as Pipes import qualified Pipes.Lift as Pipes import qualified Pipes.Attoparsec as Pipes.AP +import Pipes.Attoparsec (ParsingError (..)) import qualified Pipes.ByteString as Pipes.BS import GhcTags.Tag +import qualified GhcTags.Utils as Utils -- | Parse a stream of tags, coming from a 'Text' producer. +-- Skips malformed lines and continues parsing. Use 'tagParserWithWarnings' to +-- report skipped records. I/O exceptions still propagate to the consumer. -- tagParser :: MonadIO m => Parser (Maybe (Tag tk)) @@ -45,21 +53,83 @@ -- line and return the tag, e.g 'parseTagLine'. -> Pipes.Producer ByteString m () -> Pipes.Producer (Tag tk) m () -tagParser parser producer = void $ - Pipes.for - (Pipes.AP.parsed parser producer) - $ \case - -- ignore header lines - Just tag -> Pipes.yield tag - Nothing -> pure () +tagParser = tagParserWithWarnings (const (pure ())) --- | Streaming version of 'GhcTags.Tag.combineTags'. +-- | Recover a stream of tags and report every skipped line. +tagParserWithWarnings :: MonadIO m + => (String -> m ()) + -> Parser (Maybe (Tag tk)) + -> Pipes.Producer ByteString m () + -> Pipes.Producer (Tag tk) m () +tagParserWithWarnings report parser producer = do + Pipes.for + (Pipes.AP.parsed (Utils.parseLine parser) producer) + (\case + Left err -> Pipes.lift (report err) + -- ignore header lines + Right (Just tag) -> Pipes.yield tag + Right Nothing -> pure ()) + >>= \case + Left (err, _) -> liftIO (throwIO err) + Right () -> pure () + + +-- | Merge a sorted stream of old tags with sorted new tags from one module. +-- Replaces that module's old tags and removes duplicate output tags, including +-- when the old stream is empty. The comparison must be consistent with equality. +combineTagsStream + :: forall m (tk :: TAG_KIND). Monad m + => (Tag tk -> Tag tk -> Ordering) + -> RawFilePath -- ^ normalised module path, relative to the tags file directory + -> [Tag tk] -- ^ new tags, sorted by the supplied comparison + -> Pipes.Producer (Tag tk) m () -- ^ sorted old tags + -> Pipes.Producer (Tag tk) m () +combineTagsStream compareFn modPath new old = + merged >-> deduplicateTags compareFn modPath + where + merged :: Pipes.Producer (Tag tk) m () + merged = do + ((), remaining) <- Pipes.runStateP new $ + Pipes.for (Pipes.hoist Pipes.lift old) + (\tag -> Pipes.stateP $ fmap ((),) . combineTagsPipe compareFn modPath tag) + traverse_ Pipes.yield remaining + + +-- Equal tags have equal sorting keys, so only the current comparison group +-- needs to be remembered. Keep distinct tags with equal keys: compareTags +-- does not compare fields or definitions. Only deduplicate groups that +-- contain at least one new (modPath) tag; old-only groups are preserved as-is +-- because etags loses tagKind on round-trip, making formerly-distinct tags +-- look identical after parsing. +deduplicateTags :: Monad m + => (Tag tk -> Tag tk -> Ordering) + -> RawFilePath + -> Pipes.Pipe (Tag tk) (Tag tk) m r +deduplicateTags compareFn modPath = go [] False + where + modPath' = rawFilePathToBS modPath + isNew t = modPath' == Text.encodeUtf8 (getRawFilePath (tagFilePath t)) + go seen hasNew = do + tag <- Pipes.await + let inGroup = case seen of + previous : _ | compareFn previous tag == EQ -> True + _ -> False + if inGroup + then let hasNew' = hasNew || isNew tag + in if hasNew' && tag `elem` seen + then go seen hasNew' + else Pipes.yield tag >> go (tag : seen) hasNew' + else Pipes.yield tag >> go [tag] (isNew tag) + + +-- | One merge step for an old tag. This does not deduplicate the complete +-- output; use 'combineTagsStream' for a complete merge. -- combineTagsPipe :: forall m (tk :: TAG_KIND). Applicative m => (Tag tk -> Tag tk -> Ordering) - -> RawFilePath -- ^ file path from which the new tags were obtained, it should be normalised + -> RawFilePath -- ^ normalised module path, relative to the tags file directory -> Tag tk -- ^ tag read from disc -> [Tag tk] -- ^ new tags -> Pipes.Producer (Tag tk) m [Tag tk] @@ -69,12 +139,10 @@ go :: Tag tk -> [Tag tk] -> Pipes.Producer (Tag tk) m [Tag tk] - -- omitt all the tags which point to 'modPath' - -- - -- note: we check that 'tagFilePath' ends with 'modPath', which is - -- a relative path from the corresponding cabal file. + -- Omit only tags pointing to the exact module path. Both paths are + -- normalised and relative to the tags file directory. go tag as - | modPath' `BS.isSuffixOf` Text.encodeUtf8 (getRawFilePath (tagFilePath tag)) + | modPath' == Text.encodeUtf8 (getRawFilePath (tagFilePath tag)) = pure as go tag as@(a : as')