ghc-tags-plugin 0.6.2.0 → 1.0.0.0

raw patch · 20 files changed

+2467/−331 lines, 20 filesdep +containersdep +deepseqdep +ghc-boot-thdep ~basedep ~bytestringdep ~directoryPVP ok

version bump matches the API change (PVP)

Dependencies added: containers, deepseq, ghc-boot-th, quickcheck-instances, tasty, tasty-hunit, tasty-quickcheck, temporary

Dependency ranges changed: base, bytestring, directory, filepath, ghc, ghc-tags-core, ghc-tags-pipes, optparse-applicative, pipes, text

API changes (from Hackage documentation)

Files

• CHANGELOG.md +79/−0
• README.md +270/−68
• app/GhcTags/Check.hs +174/−0
• app/check.hs +233/−15
• ghc-tags-plugin.cabal +59/−11
• lib/Plugin/GhcTags.hs +244/−205
• lib/Plugin/GhcTags/AtomicFile.hs +41/−0
• lib/Plugin/GhcTags/CTag.hs +36/−10
• lib/Plugin/GhcTags/FileLock.hs +16/−17
• lib/Plugin/GhcTags/Options.hs +34/−5
• lib/Plugin/GhcTags/Project.hs +71/−0
• lib/Plugin/GhcTags/Timing.hs +125/−0
• test/Test/AtomicFile.hs +111/−0
• test/Test/Check.hs +199/−0
• test/Test/Ghc.hs +206/−0
• test/Test/Ghc/Generators.hs +252/−0
• test/Test/Options.hs +47/−0
• test/Test/ProjectFile.hs +174/−0
• test/Test/Timing.hs +75/−0
• test/main.hs +21/−0

@@ -1,5 +1,84 @@ # Revision history for ghctags +## 1.0.0.0 -- 2026-10-28++**Breaking changes** (existing tags files must be regenerated):++- Kind characters for type and data families are swapped to follow the+  convention that uppercase denotes an instance: `f` = type family,+  `F` = type family instance, `d` = data family, `D` = data family instance.++- The type-signature kind character changed from `~` to `⊢`.++- Pattern synonym signatures now use the signature kind (`⊢`) instead of+  the pattern kind (`p`); unsigned pattern synonyms are unaffected.++- Relative tags file paths are now resolved from the nearest+  `cabal.project`, `cabal.project.local`, or `stack.yaml` rather than+  from the package's `*.cabal` directory.++- Extend `--debug` with wall-clock timings for lock acquisition, reading,+  parsing, generation, merging, writing, and the complete update. Cover ctags,+  streaming ctags, etags, and Template Haskell updates without double-counting+  nested streaming stages.++- Add `--no-filter` / `-F` to retain signature/definition pairs and same-named+  type/data constructors. Filtering remains enabled by default.++- Correct export flags for associated type/data family instances and type defaults.+  Tag defaults using the family name rather than the right-hand-side type, and+  keep data-instance constructors private unless their exports include them.++- Omit `file:` on default and instance methods exported through their class,+  including instance signatures, while retaining it on nested local bindings.++- Emit pattern synonym signatures with the signature kind (`⊢`) and a `type:`+  field, suppressing the corresponding pattern definition tags. Unsigned pattern+  definitions retain the pattern kind (`p`).++- Add `--qualified` to emit defining-module-qualified names alongside ordinary+  names, including Template Haskell declarations, in ctags and etags output.++- Extend `gtp-check` with duplicate declaration reports, source file and line+  checks, and comparison of ctags and etags declaration locations, preserving+  duplicate counts and resolving paths relative to each tags file.+++- Resolve relative tags paths from the nearest `cabal.project` or `stack.yaml`,+  honoring `STACK_YAML`. Warn and fall back to the package directory when no+  project configuration is found.++- Extend `gtp-check` with `--etags`/`-e`, parsed tag counts, ctags program/version+  metadata, parser diagnostics and warnings for unsorted ctags files.++- Refresh ctags metadata during Template Haskell updates, replacing stale or+  missing headers. Correct signature and type/data-family kind descriptions.++- Keep local bindings when an unrelated binding with the same name has a signature.++- Filter etags declarations before applying file/line ordering, consistently+  removing redundant definitions and type constructors in both output formats.++- Apply signature filtering to Template Haskell updates, removing redundant+  function tags even when generated declarations share the same source location.++- Preserve source filenames when Template Haskell updates an etags file+  containing tags from multiple modules.++- Recover valid tags before and after malformed records, report skipped input,+  and continue updating damaged tags files, including streaming and TH updates.++- Write tags atomically: output is staged to a private temporary file beside+  the destination and published with a rename. Concurrent readers always see a+  complete file; a failed or aborted update never corrupts the existing tags.+  The temporary file inherits the destination's permissions before publication.++- Remove duplicate tags consistently in streaming and non-streaming updates,+  including when the existing tags file is empty.++- Identify compiled modules relative to the tags directory, keeping modules with+  the same source path in different packages separate in shared tags files.+ ## 0.6.2.0 -- 2026-03-08  - `GHC-9.14` support.

@@ -18,24 +18,102 @@ ----------------  ```-Usage: <program> [-e|--etags] [--stream] [--debug] [file_path]+Usage: <program> [-e|--etags] [--stream] [--debug] [--qualified] [-F|--no-filter] [file_path]   write tags from ghc abstract syntax tree  Available options:   -e,--etags               produce emacs etags file   --stream                 stream existing tags (ctags only)-  file_path                tags file: default tags or TAGS (when --etags is-                           specified)-  --debug                  debugging output+  file_path                tags file relative to cabal.project or stack.yaml:+                           default tags or TAGS (with --etags)+  --debug                  tag counts, file sizes, and update timings+  -q,--qualified           also generate names qualified by the defining module+  -F,--no-filter           retain both signatures and definitions ``` -It can be an absolute path or relative (to the `*.cabal` package file rather-than `cabal.project` file), for example:+The tags path can be absolute or relative to the nearest directory containing+`cabal.project`, `cabal.project.local`, or `stack.yaml`, searching upward from+the compiled package. Packages using the same project root can share one tags+file: ```--fplugin-opt=Plugin.GhcTags:../tags+-fplugin-opt=Plugin.GhcTags:tags ```-This is useful if for *cabal packages* which are located in subdirectories.+A `cabal.project.local` file is a project-root marker even without a+`cabal.project` beside it. A nearer marker takes precedence over configurations+in parent directories. For example, with `/repo/cabal.project` and+`/repo/package/cabal.project.local`, compiling that package writes to+`/repo/package/tags`. +If `STACK_YAML` points to an existing configuration file, its directory is used+instead. If no project configuration is found, the plugin prints a warning and+resolves the path relative to the nearest `*.cabal` package file. When no package+file is found either, it uses the compiler's working directory. Absolute output+paths are used unchanged.++## ● Qualified names++To generate module-qualified names alongside ordinary names, enable:++```+-fplugin-opt=Plugin.GhcTags:--qualified+```++For example, a declaration `lookup` in `Data.Map` produces both `lookup` and+`Data.Map.lookup`, pointing to the same declaration. This works with ctags,+streaming ctags, etags, and declarations generated by Template Haskell. Module+tags themselves are kept unchanged. Modules without a module header use `Main`.++The prefix identifies the module containing the declaration. It does not resolve+import aliases or re-exports: `import qualified Data.Map as M` does not add+`M.lookup`. Local bindings also receive module-prefixed names; those names+identify their containing module, rather than a valid qualified import.++Only recompiled modules are updated. Rebuild all modules after enabling or+disabling this option to update existing tags consistently.++## ● Signature and definition filtering++By default, a type signature replaces the corresponding function or pattern+synonym definition in the tags file. A data constructor also takes precedence+over a type constructor with the same name. To retain both tags, use:++```+-fplugin-opt=Plugin.GhcTags:--no-filter+```++The short form is `-fplugin-opt=Plugin.GhcTags:-F`. This applies to ctags,+streaming ctags, etags, and Template Haskell signature/definition pairs. Tags+remain sorted. Recompile all modules after changing this option to update+existing tags consistently.++## ● Update timings++Enable timing diagnostics with:++```+-fplugin-opt=Plugin.GhcTags:--debug+```++Each completed update reports monotonic wall-clock durations in milliseconds:++- `lock-wait`: opening and acquiring the tags-file lock.+- `read`: reading the existing tags file.+- `parse`: parsing its records.+- `generate`: extracting and preparing tags for the current module or splice.+- `merge`: combining old and new tags, including sorting where required.+- `write`: formatting, writing, and flushing the replacement's contents.+- `total`: elapsed time from before lock acquisition until after release,+  including temporary-file close/rename, bookkeeping, and other debug output.++Reports include the module, tags path, output mode, and whether the update came+from parsing or a Template Haskell declaration splice. Streaming ctags measures+each stage as records flow through it, excluding upstream work from downstream+phase times. It does not load the existing file into memory for timing.++Debug mode forces lazy results within their measured phase and adds measurement+overhead, especially when streaming. The phase times need not sum to `total`.+With debug disabled, timing does not read the clock or force additional results.+ ## ● Emacs support  To produce `etags` file you will need to pass the following option@@ -45,94 +123,178 @@  ## ● Editor configuration -By default each generated tags file is put next to the corresponding `*.cabal`-package file.  If you just have a repo with a cabal file in the main directory-`vim` default `tags` setting will work, if you have some modules in-subdirectories you will either need to set:+By default the generated `tags` file is put in the nearest directory containing+`cabal.project`, `cabal.project.local`, or `stack.yaml`. To let Vim or Neovim find+it while editing files in package subdirectories, enable searching parent+directories: ```-:set tags+=*/tags+:set tags+=./tags; ```-or pass an option to modify where tags are written, see below.+You can also pass an option to change where tags are written, see below.  ● Configuration: Ghc / Cabal / Stack ------------------------------------ -Configuration of this plugin requires some familiarity with `ghc` packages.-Check out-[documentation](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/packages.html#packages)-to use `-plugin-package` or `-plugin-package-id`.  In the examples below we-use `-plugin-package=ghc-tags-plugin` but specifying version-`-package=ghc-tags-plugin-0.0.0.0` (where `0.0.0.0` is the version you-installed), might work better.  You can use `ghc-pkg latest ghc-tags-plugin`-(likely with appropriate `--package-db` flag) to check which version is-available.+## ● Cabal: quick start with GHCi -## ● Ghc+To generate tags in a REPL session without installing the plugin separately or+editing any `.cabal` files, run: -```-ghc -plugin-package=ghc-tags-plugin -fplugin=Plugin.GhcTags+```sh+cabal repl TARGET \+  --build-depends=ghc-tags-plugin \+  --repl-options=-fplugin=Plugin.GhcTags \+  --repl-options=-fplugin-opt=Plugin.GhcTags:tags ``` -You might also need to pass `-package-db` in which you installed the plugin.+Replace `TARGET` with a component such as `lib:my-package` or `exe:my-program`.+Cabal builds the plugin and makes it available to that REPL session. This+command was tested with Cabal 3.16.1.0 and GHC 9.10.3 using a local plugin+checkout and this repository's project configuration. See Cabal's+[`--build-depends` documentation](https://cabal.readthedocs.io/en/stable/cabal-commands.html#cmdoption-repl-build-depends). -## ● Cabal+The plugin's dependencies are solved together with the target project's+dependencies, using that project's `index-state`, constraints, and+`allow-newer` settings.  You might need to modify `allow-newer` via+[`--allow-newer` documentation](https://cabal.readthedocs.io/en/stable/cabal-commands.html#cmdoption-allow-newer). -Install the `ghc-tags-plugin` to cabal store with:++This configures the REPL session only. For normal builds and HLS, use the+persistent configuration below.++## ● Cabal: persistent configuration++This setup enables the plugin through `cabal.project.local`, without changing+any `.cabal` files.++First, install the plugin into Cabal's store:++```sh+cabal install --lib ghc-tags-plugin --package-env=ghc-tags ```-cabal install --lib ghc-tags-plugin++If installation encounters the GHC 9.14 dependency bounds described above,+add `--allow-newer=pipes-safe:base,ghc-tags-pipes:base` to this command too.++The named `ghc-tags` environment keeps this installation separate from the+default GHC package environment. The configuration below loads the plugin+through its package database, so it does not require selecting that environment.+See Cabal's [package environment documentation](https://cabal.readthedocs.io/en/stable/cabal-commands.html#adding-libraries-to-ghc-package-environments).++Use the same GHC to install the plugin and build the target project. If the+project selects a particular compiler, pass `-w /absolute/path/to/ghc` to the+installation command as well. Reinstall the plugin when changing compilers.++With Cabal 3.16.1.0 or newer, run this in the target project to find its compiler+and the corresponding store directory:++```sh+cabal path --compiler-info ``` -In `cabal.project.local` file add [`program-options`] stanza, which enables the plugin-for all local packages:+Append `/package.db` to the reported `compiler-store-path` to obtain+`PACKAGE_DB`. For example, the resulting path might be:++```text+/home/alice/.cabal/store/ghc-9.10.3-1be3/package.db ```++Use the reported path rather than constructing it from the GHC version:+compiler ABI suffixes and custom store locations can change the directory name.+With older Cabal versions, locate the compiler's `package.db` in the Cabal store+(the store location can be queried with `cabal path --store-dir` where available).++Add the following [`program-options`] stanza to `cabal.project.local`:++```cabal program-options     ghc-options: -package-db=PACKAGE_DB                  -plugin-package=ghc-tags-plugin                  -fplugin=Plugin.GhcTags+                 -fplugin-opt=Plugin.GhcTags:tags ``` -`PACKAGE_DB` is likely to be something like-(all environment variables must be expanded):-```-${HOME}/.cabal/store/ghc-9.12.2/package.db-```-or on Windows (note the `""` syntax)-```-"C:\\Users\\USER_NAME\\AppData\\Roaming\\cabal\\store\\ghc-8.6.5\\package.db+Replace `PACKAGE_DB` with the absolute path found above. Environment variables+such as `$HOME` are not expanded in this file. If the path contains spaces,+quote the entire argument, for example `"-package-db=C:/Users/My Name/cabal/store/ghc-VERSION/package.db"`.++The stanza applies to all local packages. You can now run `cabal build` or+`cabal repl` normally. When HLS uses a Cabal cradle, restart it after changing+the configuration so it reloads the compiler options.++The default relative path shares a tags file across packages that resolve to the+same project root. To choose an absolute destination, use:++```text+-fplugin-opt=Plugin.GhcTags:/absolute/path/to/tags ``` -Note that you can also configure in this way non-local projects.  You will-likely want to pass `-fplugin-opt=Plugin.GhcTags=PATH` where `PATH` is *an-absolute* path to your `tags` file.+Relative paths in the examples above are resolved from the project configuration+directory. For example, `../tags` writes one directory above the selected+`cabal.project`, `cabal.project.local`, or `stack.yaml`. +To apply the plugin to dependencies as well, use a `package *` stanza instead+of `program-options`. This can rebuild dependencies and applies the options to+the plugin's own dependencies too; install the plugin before enabling it. -## ● Stack+## ● GHC directly -This is alternative method, which also could be modified for `cabal` (but it is-not as nice as the previous method where you don't need to modify any files-checked in a VCS).+After installing the plugin, pass its package database and enable it: -Add `ghc-tags-plugin` to  `build-depends` in your `*.cabal` files. (You should-hide it behind a cabal flag).  And add these lines to `stack.yaml` file:+```sh+ghc -package-db=PACKAGE_DB \+    -plugin-package=ghc-tags-plugin \+    -fplugin=Plugin.GhcTags Main.hs+``` +Replace `PACKAGE_DB` as described above. If multiple plugin versions are+installed, select one with `-plugin-package=ghc-tags-plugin-VERSION`, or use+`-plugin-package-id=UNIT_ID` to select a particular installed instance. Inspect+the database with:++```sh+ghc-pkg --package-db=PACKAGE_DB list ghc-tags-plugin ```-extra-deps:-  - git: https://github.com/coot/ghc-tags-plugin-    commit: a841dae7fb9c335101f7fa4187d02687d306f972 -test-project: -plugin-package=ghc-tags-plugin+See GHC's [package documentation](https://downloads.haskell.org/ghc/latest/docs/users_guide/packages.html)+and [compiler plugin documentation](https://downloads.haskell.org/ghc/latest/docs/users_guide/extending_ghc.html#using-compiler-plugins).++## ● Stack++Add `ghc-tags-plugin` to `build-depends` in the relevant components of your+`.cabal` files, optionally behind a development flag. If the plugin is not in+your snapshot, add a release compatible with the snapshot's GHC to `extra-deps`+in `stack.yaml`.++Configure the target package in `stack.yaml` under `ghc-options`:++```yaml+ghc-options:+  my-package: -plugin-package=ghc-tags-plugin               -fplugin=Plugin.GhcTags+              -fplugin-opt=Plugin.GhcTags:tags ``` +Replace `my-package` with your package name. This Stack setup uses a declared+build dependency; the Cabal setups above avoid changing `.cabal` files.+ ## ● Ghcid -If you follow the cabal configuration as above (using `stack` should work too)+For automatic tag updates while editing, use the REPL quick start with ghcid:++```sh+ghcid --command="cabal repl TARGET --build-depends=ghc-tags-plugin --repl-options=-fplugin=Plugin.GhcTags --repl-options=-fplugin-opt=Plugin.GhcTags:tags" ```-ghcid --comaand "cabal repl project"++If you have already enabled the plugin in `cabal.project.local`, use:++```sh+ghcid --command="cabal repl TARGET" ```-will update `tags` file as you modify your project. +Replace `TARGET` with the component you want ghcid to load. + ## ● Makefile  The [Makefile](https://github.com/coot/ghc-tags-plugin/blob/master/Makefile)@@ -140,6 +302,45 @@ package in a `package.db` (by default into `cabal` store).  This is mostly for development, but it could be useful in other scenarios as well. +## ● Checking and comparing tags files++The optional `gtp-check` development tool reports tag counts, ctags metadata,+parser diagnostics, sorting problems, repeated declaration locations, missing+or unreadable source files, and line numbers outside their source files:++```sh+cabal run -fgtp-check gtp-check -- tags+cabal run -fgtp-check gtp-check -- --etags TAGS+```++Source paths are resolved relative to the directory containing each tags file,+so the command can be run from another directory. Duplicate locations mean+entries with the same source file, tag name and line number; kinds and columns+are not used to distinguish them.++For a tags file copied elsewhere, pass `--source-root /path/to/original/root`+to resolve source paths from its original directory. This override applies to+both files when comparing snapshots.++To compare the declarations in two files:++```sh+cabal run -fgtp-check gtp-check -- tags --compare TAGS+cabal run -fgtp-check gtp-check -- --etags TAGS --compare tags+```++The format of the comparison file is detected automatically. Both files can+also use the same format. Comparison uses canonical source paths, names and+line numbers, and preserves duplicate counts. Differences are reported with+concrete declaration locations. Tags without numeric line addresses are+reported and excluded from line checks and comparison; a ctags `line:` field+can supply the line number for an entry addressed by a search pattern.++Each diagnostic category shows up to ten examples by default. Use+`--max-examples N` to change the limit, or `--max-examples 0` to show all.+Tags-file read or parse errors and unequal comparisons return a nonzero exit+status. Other findings are warnings.+ ● Exceptions ------------ @@ -158,25 +359,26 @@ ● Tips ------ -- If you're getting installation problems when running-  `cabal install --lib ghc-tags-plugin`; you may need to--  * remove the installed version from-    `~/.ghc/x86_64-linux-8.6.5/environments/default`-  (or whatever is your default environment)--  * unregister the installed version from cabal store (you can check what is-  installed in your store with `ghc-pkg --package=PACKAGE_DB list | grep ghc-tags`-  for the following command):+- If GHC cannot find the installed plugin, check that installation and+  compilation use the same compiler and package database: -  ```-  ghc-pkg --package-db=PACKAGE_DB unregister z-ghc-tags-plugin-z-ghc-tags-library ghc-tags-plugin+  ```sh+  ghc-pkg --package-db=PACKAGE_DB list ghc-tags-plugin   ``` +  After changing GHC versions, reinstall the plugin with the new compiler and+  update `PACKAGE_DB` in `cabal.project.local`.+ - The plugin is safe for concurrent compilation, i.e. setting `jobs: $ncpus` is   safe.  The plugin holds an exclusive (advisory) lock on a lock file.  This   will create synchronisation between threads / process which are using   the same `tags` file.++- Tag updates are written to a temporary file and renamed over the destination+  only after a successful write. Interrupted compilation (including editor+  cancellation) leaves the previous tags file intact. If tags were lost with an+  older plugin version, rebuild the affected modules with `-fforce-recomp` to+  regenerate them; an incremental build may skip those modules.  - If you are working on a larger project, it might be better to not collect all   tags in a single `tags` file, since at every compilation step one will need

@@ -0,0 +1,174 @@+{-# LANGUAGE GADTs            #-}+{-# LANGUAGE LambdaCase       #-}+{-# LANGUAGE NamedFieldPuns   #-}+{-# LANGUAGE TypeApplications #-}++-- | Format-independent inspection of declaration locations.+module GhcTags.Check+  ( TagLocation (..)+  , Declaration (..)+  , SourceReport (..)+  , tagLocation+  , resolveTagPaths+  , declarationCounts+  , duplicateDeclarations+  , compareDeclarations+  , countSourceLines+  , checkSources+  ) where++import Control.Exception (IOException, displayException, evaluate, try)+import Control.Monad (forM)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BSC+import qualified Data.List as List+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Maybe (mapMaybe, maybeToList)+import Data.Text (Text)+import qualified Data.Text as Text+import System.Directory (canonicalizePath, makeAbsolute)+import System.FilePath (normalise, (</>))+import System.IO.Error (isDoesNotExistError)+import Text.Read (readMaybe)++import GhcTags.Tag+  ( Tag (..), TagAddress (..), TagField (..), TagFields (..)+  , TagFilePath (..), TagName (..)+  )+++data TagLocation = TagLocation+  { sourcePath :: FilePath+  , sourceLine :: Maybe Int+  , sourceName :: Text+  }+  deriving (Eq, Ord, Show)++-- | The information shared by ctags and etags. Kind, column and byte offset+-- are deliberately absent: they cannot be compared across the two formats.+data Declaration = Declaration+  { declarationPath :: FilePath+  , declarationLine :: Int+  , declarationName :: Text+  }+  deriving (Eq, Ord, Show)++data SourceReport = SourceReport+  { missingSources    :: [FilePath]+  , unreadableSources :: [(FilePath, String)]+  , invalidLines      :: [(Declaration, Int)]+    -- ^ Declaration and the number of lines in its source file.+  }+  deriving (Eq, Show)+++tagLocation :: Tag tk -> TagLocation+tagLocation tag = TagLocation+  { sourcePath = Text.unpack $ getRawFilePath $ tagFilePath tag+  , sourceLine = case tagAddr tag of+      TagLine line      -> Just line+      TagLineCol line _ -> Just line+      NoAddress         -> Nothing+      TagCommand _      -> case tagFields tag of+        TagFields fields -> case mapMaybe lineField fields of+          line : _ -> Just line+          []       -> Nothing+  , sourceName = getTagName $ tagName tag+  }+  where+    lineField TagField {fieldName, fieldValue}+      | fieldName == Text.pack "line" = readMaybe $ Text.unpack fieldValue+      | otherwise = Nothing+++-- | Resolve each distinct path once, relative to the supplied source root.+-- Canonicalization also handles symlinks.+resolveTagPaths :: FilePath -> [TagLocation] -> IO [TagLocation]+resolveTagPaths sourceRoot tags = do+    directory <- makeAbsolute sourceRoot+    paths <- forM (Map.keys $ Map.fromList [(sourcePath tag, ()) | tag <- tags]) $ \path -> do+      let absolute = directory </> path+      result <- try (canonicalizePath absolute) :: IO (Either IOException FilePath)+      -- Preserve a usable path for read diagnostics if canonicalization fails.+      pure (path, either (const $ normalise absolute) id result)+    let resolvedPaths = Map.fromList paths+    pure [tag {sourcePath = resolvedPaths Map.! sourcePath tag} | tag <- tags]+++declaration :: TagLocation -> Maybe Declaration+declaration TagLocation {sourcePath, sourceLine, sourceName} =+    (\line -> Declaration sourcePath line sourceName) <$> sourceLine+++declarationCounts :: [TagLocation] -> Map Declaration Int+declarationCounts = Map.fromListWith (+) . map (\location -> (location, 1))+                  . mapMaybe declaration+++duplicateDeclarations :: [TagLocation] -> Map Declaration Int+duplicateDeclarations = Map.filter (> 1) . declarationCounts+++-- | Multiset differences, preserving how many copies occur only on each side.+compareDeclarations :: [TagLocation]+                    -> [TagLocation]+                    -> (Map Declaration Int, Map Declaration Int)+compareDeclarations left right =+    ( leftCounts `difference` rightCounts+    , rightCounts `difference` leftCounts+    )+  where+    leftCounts  = declarationCounts left+    rightCounts = declarationCounts right+    difference  = Map.differenceWith $+      \a b -> if a > b then Just (a - b) else Nothing+++-- | Count lines without inventing a trailing empty line after a final LF.+-- CRLF files use the same count. An empty file has no valid line numbers.+countSourceLines :: BS.ByteString -> Int+countSourceLines bytes = BSC.count '\n' bytes+                       + if BS.null bytes || BSC.last bytes == '\n'+                           then 0 else 1+++-- | Read each source file once. Failed reads remain distinct from missing+-- files; line bounds can only be checked for successfully read sources.+checkSources :: [TagLocation] -> IO SourceReport+checkSources tags = do+    sources <- forM paths $ \path -> do+      result <- try @IOException (BS.readFile path >>= evaluate . countSourceLines)+      pure (path, result)+    let (missing, unreadable, lineCounts) =+          List.foldl' collect ([], [], Map.empty) sources+        badLines =+          [ (location, linesInFile)+          | location@Declaration+              { declarationPath,+                declarationLine+              } <- Map.keys $ declarationCounts tags+          , linesInFile <- maybeToList (Map.lookup declarationPath lineCounts)+          , declarationLine < 1 || declarationLine > linesInFile+          ]+    pure SourceReport+      { missingSources    = reverse missing+      , unreadableSources = reverse unreadable+      , invalidLines      = badLines+      }+  where+    paths = Map.keys $ Map.fromList [(sourcePath tag, ()) | tag <- tags]++    collect :: ([FilePath], [(FilePath, String)], Map FilePath Int)+            -> (FilePath, Either IOException Int)+            -> ([FilePath], [(FilePath, String)], Map FilePath Int)+    collect (missing, unreadable, counts) = \case+      (path, Right linesInFile)+        -> (missing, unreadable, Map.insert path linesInFile counts)++      (path, Left err)+        |  isDoesNotExistError err+        -> (path : missing, unreadable, counts)++        |  otherwise+        -> (missing, (path, displayException err) : unreadable, counts)

@@ -1,25 +1,243 @@--- | Utility program which checks the size of tags file.------ It's a like `wc` but using `lock` file, so we don't get intermediate--- results.---+{-# LANGUAGE GADTs          #-}+{-# LANGUAGE NamedFieldPuns #-}++-- | Inspect a consistent snapshot of a ctags or etags file. module Main where +import           Control.Exception (IOException, displayException, handle)+import           Control.Monad (when) import qualified Data.ByteString as BS-import qualified Data.ByteString.Char8 as BSC-import           System.FilePath-import           System.IO-import           System.Environment+import           Data.Either (partitionEithers)+import qualified Data.Map.Strict as Map+import           Data.Maybe (fromMaybe)+import qualified Data.Text as Text+import           Options.Applicative+import           System.Exit (exitFailure)+import           System.FilePath (splitFileName, takeDirectory, (</>))+import           System.IO (hPutStrLn, stderr)+import           Text.Read (readMaybe) +import qualified GhcTags.CTag as CTag+import qualified GhcTags.ETag as ETag+import qualified GhcTags.Check as Check+import           GhcTags.Tag (tagName)+ import           Plugin.GhcTags.FileLock  +data Options = Options+  { etags       :: Bool+  , filePath    :: FilePath+  , compareFile :: Maybe FilePath+  , sourceRoot  :: Maybe FilePath+  , maxExamples :: Int+  }+++optionsParser :: Parser Options+optionsParser = Options+    <$> switch (  long "etags"+               <> short 'e'+               <> help "read an emacs etags file")+    <*> strArgument (  metavar "FILE"+                    <> help "tags file to inspect"+                    <> showDefault+                    <> value "tags"+                    )+    <*> optional (strOption+          ( long "compare"+         <> metavar "FILE"+         <> help "compare declaration locations with FILE (ctags/etags detected automatically)"))+    <*> optional (strOption+          ( long "source-root"+         <> metavar "DIR"+         <> help "resolve source paths in both files relative to DIR (default: each tags file's directory)"))+    <*> option (eitherReader readLimit)+          ( long "max-examples"+         <> metavar "N"+         <> value 10+         <> showDefault+         <> help "maximum examples per diagnostic category; 0 shows all")+  where+    readLimit inputText = case readMaybe inputText of+      Just n | n >= 0 -> Right n+      _ -> Left "expected a non-negative integer"+++data Format = CTags | ETags+  deriving (Eq, Show)++data ParsedFile = ParsedFile+  { parsedPath :: FilePath+  , parsedLocations :: [Check.TagLocation]+  }++ main :: IO () main = do-    file :_ <- getArgs-    withFileLock False (lockFile file) ExclusiveLock $ \_h -> do-      numOfLines <- length . BSC.lines <$> BS.readFile file-      putStrLn (show numOfLines)+    options <- execParser $+      info (optionsParser <**> helper)+        (fullDesc <> progDesc "Parse a tags file and report metadata, counts and diagnostics")+    handle reportIOException (checkFiles options)+++checkFiles :: Options -> IO ()+checkFiles Options { etags,+                     filePath,+                     compareFile,+                     sourceRoot,+                     maxExamples }+    = do+    primary <- inspectFile maxExamples sourceRoot (Just $ if etags then ETags else CTags) filePath+    case compareFile of+      Nothing -> pure ()+      Just otherPath -> do+        other <- inspectFile maxExamples sourceRoot Nothing otherPath+        reportComparison maxExamples primary other+++inspectFile :: Int -> Maybe FilePath -> Maybe Format -> FilePath -> IO ParsedFile+inspectFile limit sourceRootOverride requestedFormat path = do+    bytes <- withFileLock_ (lockFile path) SharedLock (BS.readFile path)+    let format = maybe (detectFormat bytes) id requestedFormat+        warning message = reportWarning (path ++ ": " ++ message)++        parseResult :: Either String ([String], a) -> IO a+        parseResult result = case result of+          Left err -> reportError (path ++ ": " ++ err)+          Right (warnings, parsed) -> do+            reportExamples limit (path ++ ": parse warnings") [path ++ ": " ++ message | message <- warnings]+            pure parsed+    putStrLn ("File: " ++ path ++ if format == ETags then " (etags)" else " (ctags)")+    locations <- case format of+      ETags -> do+        tags <- ETag.parseTagsFileRecovering bytes >>= parseResult+        pure $ map Check.tagLocation tags+      CTags -> do+        parsed <- CTag.parseTagsFileRecovering bytes >>= parseResult+        let (headers, tags) = partitionEithers parsed+            adjacent = zip tags (drop 1 tags)+        mapM_ reportHeader headers+        if any (\(a, b) -> tagName a > tagName b) adjacent+          then warning "ctags are not sorted by name"+          else when (any (\(a, b) -> CTag.compareTags a b == GT) adjacent) $+            warning "ctags names are sorted, but secondary ordering differs from ghc-tags-plugin"+        pure $ map Check.tagLocation tags+    resolved <- Check.resolveTagPaths (fromMaybe (takeDirectory path) sourceRootOverride) locations+    let duplicates = Check.duplicateDeclarations resolved+        sourceFiles = Map.fromList [(Check.sourcePath tag, ()) | tag <- resolved]+        unlocated = length $ filter ((== Nothing) . Check.sourceLine) resolved+    putStrLn ("Tags: " ++ show (length resolved))+    putStrLn ("Source files: " ++ show (Map.size sourceFiles))+    putStrLn ("Declaration locations: " ++ show (Map.size $ Check.declarationCounts resolved))+    putStrLn ("Duplicate declaration locations: " ++ show (Map.size duplicates)+           ++ " (" ++ show (sum $ map (subtract 1) $ Map.elems duplicates) ++ " extra tags)")+    reportExamples limit (path ++ ": duplicate locations")+      [ path ++ ": duplicate declaration location: " ++ displayDeclaration location+        ++ " (" ++ show count ++ " tags)"+      | (location, count) <- Map.toAscList duplicates+      ]+    when (unlocated > 0) $ warning $+      show unlocated ++ " tags have no numeric line address; excluded from line checks and declaration comparison"+    sources <- Check.checkSources resolved+    reportSources limit path sources+    pure ParsedFile {parsedPath = path, parsedLocations = resolved}+++detectFormat :: BS.ByteString -> Format+detectFormat bytes = case BS.uncons $ BS.dropWhile (`elem` [9, 10, 13, 32]) bytes of+    Just (12, _) -> ETags+    _            -> CTags+++reportSources :: Int -> FilePath -> Check.SourceReport -> IO ()+reportSources limit path Check.SourceReport+  {Check.missingSources, Check.unreadableSources, Check.invalidLines} = do+    putStrLn ("Missing source files: " ++ show (length missingSources))+    putStrLn ("Unreadable source files: " ++ show (length unreadableSources))+    putStrLn ("Invalid line numbers: " ++ show (length invalidLines))+    reportExamples limit (path ++ ": missing files")+      [path ++ ": source file does not exist: " ++ source | source <- missingSources]+    reportExamples limit (path ++ ": unreadable files")+      [path ++ ": cannot read source file " ++ source ++ ": " ++ err | (source, err) <- unreadableSources]+    reportExamples limit (path ++ ": invalid line numbers")+      [ path ++ ": invalid line number: " ++ displayDeclaration location+        ++ " (source has " ++ show count ++ " lines)"+      | (location, count) <- invalidLines+      ]+++reportComparison :: Int -> ParsedFile -> ParsedFile -> IO ()+reportComparison limit left right = do+    let (onlyLeft, onlyRight) = Check.compareDeclarations (parsedLocations left) (parsedLocations right)+        reportOnly file difference = do+          putStrLn ("Only in " ++ file ++ ": " ++ show (sum $ Map.elems difference)+                 ++ " tags at " ++ show (Map.size difference) ++ " declaration locations")+          reportExamples limit ("only in " ++ file)+            [ "only in " ++ file ++ ": " ++ displayDeclaration location+              ++ " (" ++ show count ++ " tags)"+            | (location, count) <- Map.toAscList difference+            ]+    putStrLn ("Comparison: " ++ parsedPath left ++ " vs " ++ parsedPath right)+    reportOnly (parsedPath left) onlyLeft+    reportOnly (parsedPath right) onlyRight+    if Map.null onlyLeft && Map.null onlyRight+      then putStrLn "Comparable declaration locations match (including duplicate counts)."+      else exitFailure+++displayDeclaration :: Check.Declaration -> String+displayDeclaration Check.Declaration {Check.declarationPath, Check.declarationLine, Check.declarationName} =+    declarationPath ++ ":" ++ show declarationLine ++ ": " ++ show (Text.unpack declarationName)+++reportExamples :: Int -> String -> [String] -> IO ()+reportExamples limit category examples = do+    let shown = if limit == 0 then examples else take limit examples+        remaining = length examples - length shown+    mapM_ reportWarning shown+    when (remaining > 0) $ reportWarning $+      category ++ ": " ++ show remaining ++ " more (use --max-examples 0 to show all)"+++reportHeader :: CTag.Header -> IO ()+reportHeader CTag.Header { CTag.headerType,+                           CTag.headerArg,+                           CTag.headerComment } =+    case headerType of+      CTag.ProgramName ->+        putStrLn (withComment $ "Program: " ++ Text.unpack headerArg)+      CTag.ProgramVersion ->+        putStrLn (withComment $ "Version: " ++ Text.unpack headerArg)+      CTag.FileFormat ->+        putStrLn (withComment $ "FileFormat: " ++ show headerArg)+      CTag.FileSorted ->+        putStrLn (withComment $ "FileSorted: " ++ show headerArg)+      _ -> pure ()+   where-    lockFile file = case splitFileName file of-      (dir, name) -> dir </> "." ++ name ++ ".lock"+    withComment :: String -> String+    withComment a+      | not (Text.null headerComment)+      = a ++ " (" ++  Text.unpack headerComment ++ ")"+      | otherwise+      = a+++reportWarning :: String -> IO ()+reportWarning message = hPutStrLn stderr ("Warning: " ++ message)+++reportError :: String -> IO a+reportError message = do+    hPutStrLn stderr ("Error: " ++ message)+    exitFailure+++reportIOException :: IOException -> IO ()+reportIOException = reportError . displayException+++lockFile :: FilePath -> FilePath+lockFile file = case splitFileName file of+    (dir, name) -> dir </> "." ++ name ++ ".lock"

@@ -1,6 +1,6 @@ cabal-version:       3.0 name:                ghc-tags-plugin-version:             0.6.2.0+version:             1.0.0.0 synopsis:            A compiler plugin which generates tags file from GHC parsed syntax tree. description:   __etags__ format.  For a standalone `ghc-tags` command look for or@@ -12,10 +12,10 @@ license-file:        LICENSE author:              Marcin Szamotulski maintainer:          coot@coot.me-copyright:           (c) 2020-2025, Marcin Szamotulski+copyright:           (c) 2020-2026, Marcin Szamotulski category:            Development stability:           alpha-extra-source-files:  CHANGELOG.md+extra-doc-files:     CHANGELOG.md                      README.md homepage:            https://github.com/coot/ghc-tags-plugin#readme bug-reports:         https://github.com/coot/ghc-tags-plugin/issues@@ -46,39 +46,87 @@   exposed-modules:     Plugin.GhcTags                        Plugin.GhcTags.Options                        Plugin.GhcTags.FileLock-  other-modules:       Plugin.GhcTags.CTag+  other-modules:       Plugin.GhcTags.AtomicFile+                       Plugin.GhcTags.CTag+                       Plugin.GhcTags.Project+                       Plugin.GhcTags.Timing                        Paths_ghc_tags_plugin   autogen-modules:     Paths_ghc_tags_plugin-  build-depends:       base              >=4.12 && < 4.23,-                       bytestring        >=0.10 && < 0.13,+  build-depends:       base              >=4.12 && <4.23,+                       bytestring        >=0.10 && <0.13,+                       containers        >=0.6.0.1 && <0.9,+                       deepseq           >=1.4 && <1.6,                        directory        ^>=1.3,-                       filepath         ^>=1.4 || ^>= 1.5,+                       filepath         ^>=1.4 || ^>=1.5,                        ghc               >=8.4 && <10,                        lukko            ^>=0.1,                        mtl               >=2.2 && <2.4,                        optparse-applicative-                                         >=0.15.1 && < 0.19,+                                         >=0.15.1 && <0.20,                        pipes            ^>=4.3,                        pipes-bytestring ^>=2.1,                        pipes-safe       ^>=2.3,                        text              >=1.2 && <2.2, -                       ghc-tags-core   ^>=0.6,-                       ghc-tags-pipes  ^>=0.1.1+                       ghc-tags-core   ^>=1.0.0.0,+                       ghc-tags-pipes  ^>=0.2.0.1   default-language:    Haskell2010   executable gtp-check+  import:              warnings   if flag(gtp-check)     buildable:         True   else     buildable:         False   hs-source-dirs:      app   main-is:             check.hs+  other-modules:       GhcTags.Check   default-language:    Haskell2010-  build-depends:       base+  build-depends:       base >=4.12 && <4.23                      , bytestring+                     , containers                      , directory                      , filepath+                     , optparse-applicative+                     , text +                     , ghc-tags-core                      , ghc-tags-plugin+++test-suite tests+  import:              warnings+  type:                exitcode-stdio-1.0+  hs-source-dirs:      test lib app+  main-is:             main.hs+  other-modules:       Plugin.GhcTags.AtomicFile+                       Plugin.GhcTags.Options+                       Plugin.GhcTags.Project+                       Plugin.GhcTags.Timing+                       GhcTags.Check+                       Test.AtomicFile+                       Test.Check+                       Test.Ghc+                       Test.Ghc.Generators+                       Test.Options+                       Test.ProjectFile+                       Test.Timing+  build-depends:       base >=4.12 && <4.23,+                       bytestring,+                       containers,+                       deepseq,+                       directory,+                       filepath,+                       ghc,+                       ghc-boot-th,+                       ghc-tags-core,+                       optparse-applicative,+                       pipes,+                       quickcheck-instances,+                       tasty,+                       tasty-hunit,+                       tasty-quickcheck,+                       temporary,+                       text+  default-language:    Haskell2010

@@ -1,6 +1,7 @@ {-# LANGUAGE CPP                 #-} {-# LANGUAGE BangPatterns        #-} {-# LANGUAGE GADTs               #-}+{-# LANGUAGE LambdaCase          #-} {-# LANGUAGE NamedFieldPuns      #-} {-# LANGUAGE RankNTypes          #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -27,9 +28,10 @@ import qualified Data.Text.Encoding as Text import           Data.Functor.Identity (Identity (..)) import           Data.List (sortBy)-import           Data.Either (partitionEithers, rights)-import           Data.Foldable (traverse_)-import           Data.Maybe (mapMaybe)+import           Data.Either (rights)+import           Data.Maybe (fromMaybe, mapMaybe)+import qualified System.Directory as Directory+import           System.Environment (lookupEnv) #if MIN_VERSION_filepath(1,4,100) import qualified System.OsPath as OsPath import           System.Directory.OsPath@@ -67,13 +69,20 @@                                   , metaRequestT                                   ) import           GHC.Driver.Hooks (Hooks (..))-import           GHC.Unit.Types   (Module)+import           GHC.Unit.Types   (Module, moduleName)+#if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0)+import           Language.Haskell.Syntax.Module.Name (moduleNameString)+#else+import           GHC.Unit.Module.Name (moduleNameString)+#endif import           GHC.Unit.Module.Location   (ModLocation (..))-import           GHC.Tc.Types (TcM)+import           GHC.Tc.Types (TcM, tcg_mod)+import           GHC.Tc.Utils.Monad (getGblEnv) import           GHC.Tc.Gen.Splice (defaultRunMeta) import           GHC.Types.SrcLoc (Located) import qualified GHC.Types.SrcLoc as GHC (SrcSpan (..), getLoc, srcSpanFile) import           GHC.Driver.Session (DynFlags)+import           GHC.Driver.Session as GHC (workingDirectory)  import           GHC.Hs (GhcPs, GhcTc, HsModule (..), LHsDecl, LHsExpr) import           GHC.Utils.Outputable (($+$), ($$))@@ -88,7 +97,10 @@ import qualified GhcTags.ETag as ETag  import           Plugin.GhcTags.Options+import           Plugin.GhcTags.AtomicFile import           Plugin.GhcTags.FileLock+import           Plugin.GhcTags.Timing+import           Plugin.GhcTags.Project (TagsAtRoot (..), resolveTagsFile) import qualified Plugin.GhcTags.CTag as CTag  @@ -160,11 +172,9 @@      hsParsedModule <$       case runOptionParser options of-        Success opts@Options { filePath = Identity tagsFile-                             , debug-                             } ->--           liftIO $ do+        Success parsedOptions ->+           liftIO $ withResolvedOptions dynFlags (Just ms_mod) parsedOptions $ \opts@Options+             { filePath = Identity tagsFile, debug } -> do #if MIN_VERSION_filepath(1,4,100)             tagsPath <- OsPath.encodeUtf tagsFile #endif@@ -179,7 +189,7 @@                 -- file.  This is needed when `cabal` compiles in parallel.                 -- We take the lock on the copy, otherwise the lock would be removed when                 -- we move the file.-                withFileLock debug (lockFilePath tagsFile) ExclusiveLock $ \_ -> do+                withUpdateTimings opts dynFlags ms_mod "parsed" $ \timings -> do                     mbInSize <-                       if debug                         then Just <$> getFileSize@@ -190,7 +200,7 @@ #endif                                       `catch` \(_ :: IOException) -> pure 0                         else pure Nothing-                    updateTags opts moduleSummary hpm_module+                    updateTags timings opts moduleSummary hpm_module                     when debug $ do                       let Just inSize = mbInSize                       outSize <- getFileSize@@ -224,31 +234,36 @@ data MessageType =       ReadException     | ParserException+    | ParseWarning     | WriteException     | UnhandledException     | OptionParserFailure     | DebugMessage     | SizeWarning+    | ProjectRootWarning   instance Show MessageType where     show ReadException       = "read error"     show ParserException     = "tags parser error"+    show ParseWarning        = "tags recovered after parse errors"     show WriteException      = "write error"     show UnhandledException  = "unhandled error"     show OptionParserFailure = "plugin options parser error"     show SizeWarning         = "tags file shrinked"+    show ProjectRootWarning  = "project configuration not found"     show DebugMessage        = ""    -- | Extract tags from a module and update tags file ---updateTags :: Options Identity+updateTags :: Timings+           -> Options Identity            -> ModSummary            -> Located GhcPsModule            -> IO ()-updateTags Options { etags, stream, filePath = Identity tagsFile, debug }+updateTags timings opts@Options { etags, stream, filePath = Identity tagsFile, debug }            ModSummary {ms_mod, ms_location, ms_hspp_opts = dynFlags}            lmodule = do     case (etags, stream) of@@ -274,8 +289,6 @@ #else                           tagsFile #endif-      let destFile = case FilePath.splitFileName tagsFile of-            (dir, name) -> dir FilePath.</> "." ++ name        mbInSize <-         if debug@@ -291,8 +304,14 @@               else pure (Just 0)           else pure Nothing -      withFile destFile WriteMode  $ \writeHandle ->-        withFile tagsFile ReadWriteMode $ \readHandle -> do+      withAtomicFile tagsFile $ \writeHandle ->+        handle (\(err :: ParsingError) -> do+          printMessageDoc dynFlags ParserException (Just ms_mod) (displayException err)+          pure False) $+        let withInput k+              | tagsFileExists = withFile tagsFile ReadMode (k . Just)+              | otherwise = k Nothing+        in withInput $ \readHandle -> do #if MIN_VERSION_filepath(1,4,100)           cwd <- getCurrentDirectory #else@@ -306,12 +325,13 @@           tagsDir <- rawFilePathFromBS . BSC.pack <$> canonicalizePath (fst $ FilePath.splitFileName tagsFile) #endif           case ml_hs_file ms_location of-            Nothing         -> pure ()+            Nothing         -> pure False             Just sourcePath -> do               let sourcePathBS = rawFilePathFromBS $ Text.encodeUtf8 (Text.pack sourcePath)-                  -- path of the compiled module; it is relative to the cabal file,-                  -- not the project.+                  -- Identify the module relative to the tags file, just like+                  -- the generated tags.                   modulePath =+                    fixFilePath cwd tagsDir $                     case GHC.getLoc lmodule of                       GHC.RealSrcSpan rss _ ->                           rawFilePathFromBS@@ -319,73 +339,63 @@                         . GHC.srcSpanFile                         $ rss                       GHC.UnhelpfulSpan {} ->-                        fixFilePath cwd tagsDir sourcePathBS+                        sourcePathBS                   -- text parser                   producer :: Pipes.Producer ByteString (SafeT IO) ()-                  producer-                    | tagsFileExists =-                        void (Pipes.BS.fromHandle readHandle)+                  producer = timedProducer timings ReadTags $ case readHandle of+                    Just inputHandle ->+                        void (Pipes.BS.fromHandle inputHandle)                         `Pipes.Safe.catchP` \(e :: IOException) ->                           Pipes.lift $ Pipes.liftIO $-                            -- don't re-throw; this would kill `ghc`, error-                            -- loudly and continue.-                            putDocLn dynFlags (messageDoc ReadException (Just ms_mod) (displayException e))-                    | otherwise      = pure ()+                            -- Abort the replacement rather than publish partial tags.+                            putDocLn dynFlags (messageDoc ReadException (Just ms_mod) (displayException e)) >> throwIO e+                    Nothing -> pure () -                  -- tags pipe-                  pipe :: Pipes.Effect (StateT Int (StateT [CTag] (SafeT IO))) ()-                  pipe =-                    Pipes.for-                      (Pipes.hoist Pipes.lift $ Pipes.hoist Pipes.lift (tagParser (either (const Nothing) Just <$> CTag.parseTagLine) producer)+                  parsed :: Pipes.Producer CTag (StateT Int (SafeT IO)) ()+                  parsed = timedProducer timings ParseTags $ Pipes.for+                    (Pipes.hoist Pipes.lift+                      (tagParserWithWarnings+                        (Pipes.liftIO . printMessageDoc dynFlags ParseWarning (Just ms_mod))+                        (either (const Nothing) Just <$> CTag.parseTagLine) producer)+                      `Pipes.Safe.catchP` \(e :: IOException) ->+                        Pipes.liftIO $ do+                          putDocLn dynFlags (messageDoc ParserException (Just ms_mod) (displayException e))+                          throwIO e)+                    (\tag -> modify' succ >> Pipes.yield tag)++                  pipe :: [CTag] -> Pipes.Effect (StateT Int (SafeT IO)) ()+                  pipe newTags = Pipes.for+                    (timedProducer timings MergeTags $ combineTagsStream CTag.compareTags modulePath newTags parsed)+                    (\tag ->+                      Pipes.liftIO (timed timings WriteTags $ BB.hPutBuilder writeHandle (CTag.formatTag tag))                         `Pipes.Safe.catchP` \(e :: IOException) ->-                          Pipes.lift $ Pipes.liftIO $-                            -- don't re-throw; this would kill `ghc`, error-                            -- loudly and continue.-                            putDocLn dynFlags $ messageDoc ParserException (Just ms_mod) (displayException e)-                      )-                      -- merge tags-                      (\tag -> do-                        -- update tags counter-                        modify' succ-                        Pipes.hoist Pipes.lift $-                            runCombineTagsPipe writeHandle-                              CTag.compareTags-                              CTag.formatTag-                              modulePath-                              tag-                          `Pipes.Safe.catchP` \(e :: IOException) ->-                            Pipes.lift $ Pipes.liftIO $-                              -- don't re-throw; this would kill `ghc`, error-                              -- loudly and continue.-                              putDocLn dynFlags $ messageDoc WriteException (Just ms_mod) (displayException e)-                      )+                          Pipes.liftIO $ do+                            putDocLn dynFlags (messageDoc WriteException (Just ms_mod) (displayException e))+                            throwIO e)                let tags :: [CTag]                   tags = map (fixTagFilePath cwd tagsDir)                                               -- fix file names-                       . filterAdjacentTags-                       . sortBy compareTags   -- sort+                       . prepareTagsWithOptions opts CTag.compareTags+                                              -- filter and sort+                       . qualifyTags opts ms_mod                        . mapMaybe (ghcTagToTag SingCTag dynFlags)                                               -- translate 'GhcTag' to 'Tag'-                       . getGhcTags           -- generate 'GhcTag's+                       . getGhcTags (filterOption opts)+                                              -- generate 'GhcTag's                        $ lmodule +              void $ timedNF timings GenerateTags (pure tags)+               -- Write header-              BSL.hPut writeHandle (BB.toLazyByteString (foldMap CTag.formatHeader CTag.headers))+              timed timings WriteTags $ BSL.hPut writeHandle (BB.toLazyByteString (foldMap CTag.formatHeader (CTag.headers opts)))               -- update tags file / run 'pipe'-              (parsedTags, tags') <- Pipes.Safe.runSafeT $ runStateT (execStateT (Pipes.runEffect pipe) 0) tags-              -- write the remaining tags'-              traverse_ (BSL.hPut writeHandle . BB.toLazyByteString . CTag.formatTag) tags'+              parsedTags <- Pipes.Safe.runSafeT $ execStateT (Pipes.runEffect (pipe tags)) 0 -              hFlush writeHandle+              timed timings WriteTags (hFlush writeHandle)                when debug $ do-                outSize <- getFileSize-#if MIN_VERSION_filepath(1,4,100)-                          tagsPath-#else-                          tagsFile-#endif+                outSize <- hFileSize writeHandle                 let Just inSize = mbInSize                 printMessageDoc dynFlags DebugMessage (Just ms_mod)                   (concat [ "path: "@@ -393,25 +403,13 @@                           , " parsed: "                           , show parsedTags                           , " found: "-                          , show (length tags + length tags')+                          , show (length tags)                           , " in-size: "                           , show inSize                           , " out-size: "                           , show outSize                           ])-      -#if MIN_VERSION_filepath(1,4,100)-      destPath <- OsPath.encodeUtf destFile-      destFileExists <- doesFileExist destPath-#else-      destFileExists <- doesFileExist destFile-#endif-      when destFileExists $-#if MIN_VERSION_filepath(1,4,100)-        renameFile destPath tagsPath-#else-        renameFile destFile tagsFile-#endif+              pure True       --@@ -439,10 +437,10 @@ #endif               else pure (Just 0)           else pure Nothing-      !tagsContent <- if tagsFileExists+      !tagsContent <- timed timings ReadTags $ if tagsFileExists                         then BS.readFile tagsFile                         else return mempty-      withFile tagsFile WriteMode $ \writeHandle -> do+      withAtomicFile tagsFile $ \writeHandle -> do #if MIN_VERSION_filepath(1,4,100)         cwd <- getCurrentDirectory #else@@ -456,12 +454,13 @@         tagsDir <- rawFilePathFromBS . BSC.pack <$> canonicalizePath (fst $ FilePath.splitFileName tagsFile) #endif         case ml_hs_file ms_location of-          Nothing         -> pure ()+          Nothing         -> pure False           Just sourcePath -> do             let sourcePathBS = rawFilePathFromBS $ Text.encodeUtf8 (Text.pack sourcePath)-                -- path of the compiled module; it is relative to the cabal file,-                -- not the project.+                -- Identify the module relative to the tags file, just like+                -- the generated tags.                 modulePath =+                  fixFilePath cwd tagsDir $                   case GHC.getLoc lmodule of                     GHC.RealSrcSpan rss _ ->                         rawFilePathFromBS@@ -469,43 +468,46 @@                       . GHC.srcSpanFile                       $ rss                     GHC.UnhelpfulSpan {} ->-                      fixFilePath cwd tagsDir sourcePathBS+                      sourcePathBS -            pres <- try @IOException $ CTag.parseTagsFile tagsContent+            pres <- try @IOException $ timedNF timings ParseTags $ CTag.parseTagsFileRecovering tagsContent             case pres of               Left err   ->-                putDocLn dynFlags $ messageDoc ParserException (Just ms_mod) (displayException err)+                putDocLn dynFlags (messageDoc ParserException (Just ms_mod) (displayException err)) >> pure False                Right (Left err) ->-                printMessageDoc dynFlags ParserException (Just ms_mod) err+                printMessageDoc dynFlags ParserException (Just ms_mod) err >> pure False -              Right (Right parsed) -> do+              Right (Right (warnings, parsed)) -> do+                mapM_ (printMessageDoc dynFlags ParseWarning (Just ms_mod)) warnings                 let parsedTags = rights parsed                       tags :: [CTag]                     tags = map (fixTagFilePath cwd tagsDir)                                                 -- fix file names-                         . filterAdjacentTags-                         . sortBy compareTags   -- sort+                         . prepareTagsWithOptions opts CTag.compareTags+                                                -- filter and sort+                         . qualifyTags opts ms_mod                          . mapMaybe (ghcTagToTag SingCTag dynFlags)                                                 -- translate 'GhcTag' to 'Tag'-                         . getGhcTags           -- generate 'GhcTag's+                         . getGhcTags (filterOption opts)+                                                -- generate 'GhcTag's                          $ lmodule                      combined :: [CTag]                     combined = combineTags CTag.compareTags modulePath tags parsedTags -                BB.hPutBuilder writeHandle-                          (    foldMap CTag.formatHeader CTag.headers+                void $ timedNF timings GenerateTags (pure tags)+                void $ timedNF timings MergeTags (pure combined)++                timed timings WriteTags $ BB.hPutBuilder writeHandle+                          (    foldMap CTag.formatHeader (CTag.headers opts)                             <> foldMap CTag.formatTag combined                           )                   when debug $ do-#if MIN_VERSION_filepath(1,4,100)-                  outSize <- getFileSize tagsPath-#else-                  outSize <- getFileSize tagsFile-#endif+                  timed timings WriteTags (hFlush writeHandle)+                  outSize <- hFileSize writeHandle                   let Just inSize = mbInSize                   printMessageDoc dynFlags DebugMessage (Just ms_mod)                     (concat [ "parsed: "@@ -517,6 +519,7 @@                             , " out-size: "                             , show outSize                             ])+                pure True       --@@ -544,10 +547,10 @@ #endif               else pure (Just 0)           else pure Nothing-      !tagsContent <- if tagsFileExists+      !tagsContent <- timed timings ReadTags $ if tagsFileExists                         then BS.readFile tagsFile                         else return mempty-      withFile tagsFile WriteMode $ \writeHandle -> do+      withAtomicFile tagsFile $ \writeHandle -> do #if MIN_VERSION_filepath(1,4,100)           cwd <- getCurrentDirectory #else@@ -562,20 +565,22 @@ #endif            case ml_hs_file ms_location of-            Nothing         -> pure ()+            Nothing         -> pure False             Just sourcePath -> do-              pres <- try @IOException $ ETag.parseTagsFile tagsContent+              pres <- try @IOException $ timedNF timings ParseTags $ ETag.parseTagsFileRecovering tagsContent               case pres of-                Left err   ->-                  putDocLn dynFlags $ messageDoc ParserException (Just ms_mod) (displayException err)+                Left err ->+                  False <$ putDocLn dynFlags (messageDoc ParserException (Just ms_mod) (displayException err)) -                Right (Left err) ->-                  printMessageDoc dynFlags ParserException (Just ms_mod) err+                Right (Left err) -> do+                  False <$ printMessageDoc dynFlags ParserException (Just ms_mod) err -                Right (Right parsedTags) -> do+                Right (Right (warnings, parsedTags)) -> do+                  mapM_ (printMessageDoc dynFlags ParseWarning (Just ms_mod)) warnings                   let sourcePathBS = rawFilePathFromBS                                    $ Text.encodeUtf8 (Text.pack sourcePath)                       modulePath =+                        fixFilePath cwd tagsDir $                         case GHC.getLoc lmodule of                           GHC.RealSrcSpan rss _ ->                               rawFilePathFromBS@@ -583,27 +588,27 @@                             . GHC.srcSpanFile                             $ rss                           GHC.UnhelpfulSpan {} ->-                            fixFilePath cwd tagsDir sourcePathBS+                            sourcePathBS                        tags :: [ETag]-                      tags = filterAdjacentTags-                           . sortBy ETag.compareTags+                      tags = prepareTagsWithOptions opts ETag.compareTags                            . map (fixTagFilePath cwd tagsDir)+                           . qualifyTags opts ms_mod                            . mapMaybe (ghcTagToTag SingETag dynFlags)-                           . getGhcTags+                           . getGhcTags (filterOption opts)                            $ lmodule                        combined :: [ETag]                       combined = combineTags ETag.compareTags modulePath tags parsedTags -                  BB.hPutBuilder writeHandle (ETag.formatETagsFile combined)+                  void $ timedNF timings GenerateTags (pure tags)+                  void $ timedNF timings MergeTags (pure combined) +                  timed timings WriteTags $ BB.hPutBuilder writeHandle (ETag.formatETagsFile combined)+                   when debug $ do-#if MIN_VERSION_filepath(1,4,100)-                    outSize <- getFileSize tagsPath-#else-                    outSize <- getFileSize tagsFile-#endif+                    timed timings WriteTags (hFlush writeHandle)+                    outSize <- hFileSize writeHandle                     let Just inSize = mbInSize                     printMessageDoc dynFlags DebugMessage (Just ms_mod)                       (concat [ "parsed: "@@ -615,46 +620,7 @@                               , " out-size: "                               , show outSize                               ])----- | Filter adjacent tags.----filterAdjacentTags :: [Tag tk] -> [Tag tk]-filterAdjacentTags tags =-    foldr-      (\(mprev, c, mnext) acc ->-          case (mprev, mnext) of-            -- filter out terms preceded by a type signature-            (Just p, _)  | tagName p == tagName c-                         , TkTypeSignature <- tagKind p-                         , k <- tagKind c-                         , k == TkTerm-                        || k == TkFunction-                        ->     acc--            -- filter out type constructors followed by a data constructor-            (_, Just n)  | tagName c == tagName n-                         , TkTypeConstructor <- tagKind c-                         , k <- tagKind n-                         , k == TkDataConstructor-                        || k == TkGADTConstructor-                        ->     acc--            _           -> c : acc--      )-      []-      (zip3 tags' tags tags'')-  where-    -- previous-    tags' = case tags of-      [] -> []-      _  -> Nothing : map Just (init tags)--    -- next-    tags'' = case tags of-      []   -> []-      _:ts -> map Just ts ++ [Nothing]+                  pure True   --@@ -672,19 +638,18 @@ ghcTagsMetaHook :: [CommandLineOption] -> DynFlags -> MetaHook TcM ghcTagsMetaHook options dynFlags request expr =     case runOptionParser options of-      Success Options { filePath = Identity tagsFile-                      , etags-                      , debug-                      } -> do+      Success parsedOptions -> do -        withMetaD defaultRunMeta request expr $ \decls ->-          liftIO $+        withMetaD defaultRunMeta request expr $ \decls -> do+          mod_ <- tcg_mod <$> getGblEnv+          liftIO $ withResolvedOptions dynFlags Nothing parsedOptions $ \opts@Options+            { filePath = Identity tagsFile, etags } ->             handle (\ioerr -> do                      putDocLn dynFlags                              (messageDoc UnhandledException Nothing                                (displayException ioerr))                      throwIO (GhcTagsDynFlagsPluginIOException ioerr)) $-            withFileLock debug (lockFilePath tagsFile) ExclusiveLock $ \_ -> do+            withUpdateTimings opts dynFlags mod_ "template-haskell" $ \timings -> do #if MIN_VERSION_filepath(1,4,100)             cwd <- getCurrentDirectory #else@@ -696,43 +661,57 @@ #else             tagsDir <- rawFilePathFromBS . BSC.pack <$> canonicalizePath (fst $ FilePath.splitFileName tagsFile) #endif-            tagsContent <- BSC.readFile tagsFile+            tagsContent <- timed timings ReadTags $ BSC.readFile tagsFile+            let newTags :: SingTagKind tk -> [Tag tk]+                newTags sing = qualifyTags opts mod_+                             $ mapMaybe (fmap (fixTagFilePath cwd tagsDir)+                                         . ghcTagToTag sing dynFlags)+                             $ hsDeclsToGhcTags (filterOption opts) Nothing decls             if etags               then do-                pr <- ETag.parseTagsFile tagsContent+                pr <- timedNF timings ParseTags $ ETag.parseTagsFileRecovering tagsContent                 case pr of                   Left err ->                     printMessageDoc dynFlags ParserException Nothing err -                  Right tags -> do-                    let tags' :: [ETag]+                  Right (warnings, tags) -> do+                    mapM_ (printMessageDoc dynFlags ParseWarning Nothing) warnings+                    let generated = prepareTagsWithOptions opts ETag.compareTags $ newTags SingETag+                        tags' :: [ETag]                         tags' = sortBy ETag.compareTags $                                   tags                                   ++-                                  (fmap (fixTagFilePath cwd tagsDir)-                                  . ghcTagToTag SingETag dynFlags)-                                    `mapMaybe`-                                     hsDeclsToGhcTags Nothing decls-                    BSL.writeFile tagsFile (BB.toLazyByteString $ ETag.formatTagsFile tags')+                                  generated+                    void $ timedNF timings GenerateTags (pure generated)+                    void $ timedNF timings MergeTags (pure tags')+                    withAtomicFile tagsFile $ \h -> timed timings WriteTags $ do+                      BSL.hPut h (BB.toLazyByteString $ ETag.formatETagsFile tags')+                      when (debug opts) (hFlush h)+                      pure True               else do-                pr <- fmap partitionEithers <$> CTag.parseTagsFile tagsContent+                pr <- timedNF timings ParseTags $ CTag.parseTagsFileRecovering tagsContent                 case pr of                   Left err ->                     printMessageDoc dynFlags ParserException Nothing err -                  Right (headers, tags) -> do-                    let tags' :: [Either CTag.Header CTag]-                        tags' = Left `map` headers+                  Right (warnings, parsed) -> do+                    mapM_ (printMessageDoc dynFlags ParseWarning Nothing) warnings+                    let tags = rights parsed+                        generated = prepareTagsWithOptions opts CTag.compareTags $ newTags SingCTag+                        tags' :: [Either CTag.Header CTag]+                        tags' = Left `map` CTag.headers opts                              ++ Right `map`-                                sortBy CTag.compareTags-                                ( tags-                                  ++-                                  (fmap (fixTagFilePath cwd tagsDir)-                                    . ghcTagToTag SingCTag dynFlags)-                                    `mapMaybe`-                                    hsDeclsToGhcTags Nothing decls-                                )-                    BSL.writeFile tagsFile (BB.toLazyByteString $ CTag.formatTagsFile tags')+                                (sortBy CTag.compareTags+                                  ( tags+                                    +++                                    generated+                                  ))+                    void $ timedNF timings GenerateTags (pure generated)+                    void $ timedNF timings MergeTags (pure tags')+                    withAtomicFile tagsFile $ \h -> timed timings WriteTags $ do+                      BSL.hPut h (BB.toLazyByteString $ CTag.formatTagsFile tags')+                      when (debug opts) (hFlush h)+                      pure True        Failure (ParserFailure f)  ->         withMetaD defaultRunMeta request expr $ \_ ->@@ -761,10 +740,72 @@       MetaAW k -> k <$> metaRequestAW h e  +-- Report after releasing the lock, including atomic replacement in total time.+withUpdateTimings :: Options Identity -> DynFlags -> Module -> String -> (Timings -> IO a) -> IO a+withUpdateTimings Options {debug, etags, stream, filePath = Identity tagsFile} dynFlags mod_ hook action =+    withTimings debug+      (\report -> printMessageDoc dynFlags DebugMessage (Just mod_)+        (formatTimings report ++ " hook=" ++ hook ++ " mode=" ++ mode ++ " tags=" ++ show tagsFile)) $+      \timings -> timedLock timings (withFileLock_ (lockFilePath tagsFile) ExclusiveLock) (action timings)+  where+    mode | etags = "etags"+         | stream && hook == "parsed" = "stream"+         | otherwise = "ctags"+++-- Sorting is required for merging even when filtering is disabled.+prepareTagsWithOptions :: Options Identity -> (Tag tk -> Tag tk -> Ordering) -> [Tag tk] -> [Tag tk]+prepareTagsWithOptions Options {filterOption} compareFn =+  case filterOption of+    RetainAll   -> sortBy compareFn+    RemoveTerms -> prepareTags compareFn+++-- | Add aliases only to newly extracted declarations, before sorting and+-- merging them with tags from other modules.+qualifyTags :: Options Identity -> Module -> [Tag tk] -> [Tag tk]+qualifyTags Options {qualified} mod_+  | qualified = addQualifiedTags (Text.pack $ moduleNameString $ moduleName mod_)+  | otherwise = id++ -- -- File path utils -- +-- GHC source filenames already include the component's -working-dir prefix.+-- Use this directory for project discovery, while resolving source filenames+-- against the process working directory as before.+compilerWorkingDirectory :: DynFlags -> IO FilePath+compilerWorkingDirectory dynFlags =+    Directory.makeAbsolute (fromMaybe "." (GHC.workingDirectory dynFlags))+++-- | Resolve tags file path relative to `cabal.project`, `cabal.project.local`,+-- `stack.yaml` or if none of them is found relative to last found `*.cabal`+-- file.+withResolvedOptions :: DynFlags+                    -- ^ GHC configuration+                    -> Maybe Module+                    -- ^ module being inspected+                    -> Options Identity+                    -- ^ user options+                    -> (Options Identity -> IO a)+                    -- ^ continuation+                    -> IO a+withResolvedOptions dynFlags mod_ opts@Options {filePath = Identity path} action = do+    cwd <- compilerWorkingDirectory dynFlags+    stackYaml <- traverse Directory.makeAbsolute =<< lookupEnv "STACK_YAML"+    resolveTagsFile cwd stackYaml path >>= \case+      TagsAtProjectRoot tagsFile ->+        action opts { filePath = Identity tagsFile }++      TagsAtPackageRoot tagsFile -> do+        printMessageDoc dynFlags ProjectRootWarning mod_ $+          ("No cabal.project or stack.yaml found; using " ++ tagsFile)+        action opts { filePath = Identity tagsFile }++ fixFilePath :: RawFilePath             -- ^ current directory             -> RawFilePath@@ -795,6 +836,8 @@ lockFilePath :: FilePath -> FilePath lockFilePath tagsFile =     case FilePath.splitFileName tagsFile of+      (dir, name@('.':_))+                  -> dir FilePath.</>        name ++ ".lock"       (dir, name) -> dir FilePath.</> "." ++ name ++ ".lock"  --@@ -808,35 +851,31 @@  messageDoc :: MessageType -> Maybe Module -> String -> Out.SDoc messageDoc errorType mb_mod errorMessage =-    Out.blankLine-      $+$         Out.coloured PprColour.colBold           (Out.text "GhcTagsPlugin: "             Out.<> Out.coloured messageColour (Out.text $ show errorType))-      $$-        case mb_mod of-          Just mod_ ->-            Out.coloured PprColour.colBold (Out.nest 4 $ Out.ppr mod_)-          Nothing -> Out.empty-      $$-        (Out.nest 8 $ Out.coloured messageColour (Out.text errorMessage))-      $+$-        Out.blankLine+      $$ case mb_mod of+        Just mod_ ->+          Out.coloured PprColour.colBold (Out.nest 4 $ Out.ppr mod_)+        Nothing ->+          Out.empty+      $$ (Out.nest 8 $ Out.coloured messageColour (Out.text errorMessage))       $+$ case severity of         Error ->           Out.coloured PprColour.colBold (Out.text "Please report this bug to: ")             Out.<> Out.text "https://github.com/coot/ghc-tags-plugin/issues"-          $+$ Out.blankLine-        Warning -> Out.blankLine-        Debug -> Out.blankLine+        Warning -> Out.empty+        Debug   -> Out.empty   where     severity = case errorType of       ReadException       -> Error       ParserException     -> Error+      ParseWarning        -> Warning       WriteException      -> Error       UnhandledException  -> Error       OptionParserFailure -> Warning       SizeWarning         -> Warning+      ProjectRootWarning  -> Warning       DebugMessage        -> Debug      messageColour = case severity of

@@ -0,0 +1,41 @@+module Plugin.GhcTags.AtomicFile (withAtomicFile) where++import Control.Exception (bracket, finally)+import Control.Monad (when)+import System.Directory (canonicalizePath, copyPermissions, removeFile, renameFile)+import System.FilePath (takeDirectory, takeFileName)+import System.IO (Handle, hClose, openBinaryTempFile)+import System.IO.Error (catchIOError, isDoesNotExistError)++-- | Build a replacement beside the destination, then publish it with a rename.+-- The caller must hold the destination's lock for the whole read/modify/write.+-- Returning False leaves the original untouched (e.g. after a parse error).+--+-- If @path@ is a symlink the rename updates the symlink's target, not the+-- symlink itself, so a shared tags file stays in sync with the configured+-- path.+withAtomicFile :: FilePath -> (Handle -> IO Bool) -> IO ()+withAtomicFile path write = do+    -- Resolve symlinks so the temp file lands beside the real destination and+    -- the final rename updates the target rather than replacing the symlink.+    -- Falls back to the original path on the first write (file doesn't exist).+    dest <- canonicalizePath path `catchIOError` \_ -> pure path+    bracket+      (openBinaryTempFile (takeDirectory dest) ("." ++ takeFileName dest ++ ".tmp"))+      (\(tmp, h) -> hClose h `finally` removeTemp tmp)+      (\(tmp, h) -> do+          commit <- write h+          -- Close before renaming; this is subtle.  If `hClose` throws, we+          -- won't overwrite the `dest`, if we'd just use `hFlush` instead, it+          -- could succeed, then we'd overwrite the `dest` and `hClose` and+          -- `hClose` fail afterwards.+          hClose h+          when commit $ do+            -- Preserve the destination's permissions on the replacement.+            -- Silently skip when the destination doesn't exist yet (first write).+            copyPermissions dest tmp `catchIOError` \err ->+              if isDoesNotExistError err then pure () else ioError err+            renameFile tmp dest)+  where+    removeTemp tmp = removeFile tmp `catchIOError` \err ->+      if isDoesNotExistError err then pure () else ioError err

@@ -1,22 +1,26 @@+{-# LANGUAGE NamedFieldPuns    #-} {-# LANGUAGE OverloadedStrings #-}  module Plugin.GhcTags.CTag where +import           Data.Functor.Identity+import           Data.Text (Text) import qualified Data.Text as Text-import Data.Version+import           Data.Version -import Paths_ghc_tags_plugin+import           Paths_ghc_tags_plugin +import           Plugin.GhcTags.Options (Options (..), Filter (..)) import           GhcTags.CTag.Header  -headers :: [Header]-headers =+headers :: Options Identity -> [Header]+headers options =     [ Header FileFormat     Nothing 2 ""     , Header FileSorted     Nothing 1 ""     , Header FileEncoding   Nothing "utf-8" ""     , Header ProgramAuthor  Nothing "Marcin Szamotulski" ""-    , Header ProgramName    Nothing "ghc-tags-plugin" ""+    , Header ProgramName    Nothing "ghc-tags-plugin" (displayOptions options)     , Header ProgramUrl     Nothing "https://hackage.haskell.org/package/ghc-tags-plugin" ""     , Header ProgramVersion Nothing (Text.pack $ showVersion version) "" @@ -34,18 +38,40 @@     , Header KindDescription haskellLang "g" "gadt constructor"     , Header KindDescription haskellLang "r" "record field"     , Header KindDescription haskellLang "≡" "type synonym"-    , Header KindDescription haskellLang "~" "type signature"+    , Header KindDescription haskellLang "⊢" "type signature"     , Header KindDescription haskellLang "p" "pattern synonym"     , Header KindDescription haskellLang "C" "type class"     , Header KindDescription haskellLang "m" "type class member"     , Header KindDescription haskellLang "i" "type class instance"     , Header KindDescription haskellLang "x" "type class instance member"-    , Header KindDescription haskellLang "F" "type family"-    , Header KindDescription haskellLang "f" "type family instance"-    , Header KindDescription haskellLang "D" "data type family"-    , Header KindDescription haskellLang "d" "data type family instance"+    , Header KindDescription haskellLang "f" "type family"+    , Header KindDescription haskellLang "F" "type family instance"+    , Header KindDescription haskellLang "d" "data type family"+    , Header KindDescription haskellLang "D" "data type family instance"     , Header KindDescription haskellLang "I" "foreign import"     , Header KindDescription haskellLang "E" "foreign export"     ]   where     haskellLang = Just "Haskell"+++displayOptions :: Options Identity -> Text+displayOptions Options { etags,+                         stream,+                         filePath = Identity filePath,+                         debug,+                         qualified,+                         filterOption } =+    Text.intercalate " " $+      [ "--etags"  | etags ]+      +++      [ "--stream" | stream ]+      +++      [ "--debug"  | debug ]+      +++      [ "--qualified" | qualified ]+      +++      [ "--no-filter" | RetainAll <- pure filterOption ]+      +++      [ Text.pack filePath ]+

@@ -1,26 +1,25 @@ module Plugin.GhcTags.FileLock-  ( withFileLock+  ( withFileLock_   , LockMode (..)   ) where  import           Control.Exception-import           Control.Monad (when)- import           Lukko  -- | 'flock' base lock (on posix) or `LockFileEx` on Windows. ---withFileLock :: Bool -- ^ debug option-             -> FilePath -> LockMode -> (FD -> IO x) -> IO x-withFileLock debug path mode k =-    bracket-      (fdOpen path)-      (\h -> fdClose h)-      $ \h ->-        bracket-          (do fdLock h mode-              when debug (putStrLn "lock: taken"))-          (\_ ->-           do when debug (putStrLn "lock: releasing")-              fdUnlock h)-          (\_ -> k h)+withFileLock_ :: FilePath+              -> LockMode+              -> IO a+              -> IO a+withFileLock_ path mode io =+  bracket+    (fdOpen path)+    fdClose+    $ \h ->+      -- lock the file using internal bracket, so if `fdLock` throws, we will+      -- still close the file handle.+      bracket_+        (fdLock h mode)+        (fdUnlock h)+        io

@@ -5,6 +5,7 @@ module Plugin.GhcTags.Options   ( Options (..)   , ParserResult (..)+  , Filter (..)   , runOptionParser   ) where @@ -13,7 +14,9 @@ import           Data.Functor.Identity (Identity (..)) import           Options.Applicative +import           GhcTags.Ghc (Filter (..)) + etagsParser :: Parser Bool etagsParser = switch $        short 'e'@@ -32,15 +35,30 @@ filePathParser :: Parser FilePath filePathParser =     strArgument $-         help "tags file: default tags or TAGS (when --etags is specified)"+         help "tags file relative to cabal.project or stack.yaml: default tags or TAGS (with --etags)"       <> metavar "file_path"  debugParser :: Parser Bool debugParser = switch $        long "debug"     <> showDefault-    <> help "debug"+    <> help "report tag counts, file sizes, and update timings" +qualifiedParser :: Parser Bool+qualifiedParser = switch $+       short 'q'+    <> long "qualified"+    <> help "also generate names qualified by the defining module"++filterParser :: Parser Filter+filterParser =+        bool RemoveTerms RetainAll+    <$> switch (+             short 'F'+          <> long "no-filter"+          <> help "retain both signatures and definitions instead of filtering redundant tags"+        )+ -- | /ghc-tags-plugin/ options -- data Options f = Options@@ -54,10 +72,17 @@     -- file destination.    , filePath :: f FilePath-    -- ^ file path to the tags file (relative to the @*.cabal@ file).  The+    -- ^ file path to the tags file, relative to @cabal.project@ or @stack.yaml@.+    -- If neither is found, use the @*.cabal@ package directory and warn. The     -- default is either 'tags' (if 'etags' if 'False') or 'TAGS' otherwise.    , debug :: Bool++  , qualified :: Bool+    -- ^ Also generate module-qualified aliases alongside ordinary names.++  , filterOption :: Filter+    -- ^ Retain signatures and definitions; filtering is enabled by default.   }  deriving instance Show (Options Identity)@@ -70,6 +95,8 @@          <*> streamParser          <*> (foldMap (Last . Just) <$> many filePathParser)          <*> debugParser+         <*> qualifiedParser+         <*> filterParser   parserInfo :: ParserInfo (Options Last)@@ -83,12 +110,14 @@ runOptionParser = fmap defaultOptions . execParserPure defaultPrefs parserInfo   where     defaultOptions :: Options Last -> Options Identity-    defaultOptions Options { etags, stream, filePath, debug } =+    defaultOptions Options { etags, stream, filePath, debug, qualified, filterOption } =         Options {             etags,             stream,             filePath = Identity filePath',-            debug+            debug,+            qualified,+            filterOption           }       where         filePath' =

@@ -0,0 +1,71 @@+module Plugin.GhcTags.Project+  ( TagsAtRoot (..)+  , resolveTagsFile+  ) where++import Data.Maybe (fromMaybe)+import System.Directory (canonicalizePath, doesFileExist, listDirectory)+import System.FilePath (isAbsolute, normalise, takeDirectory, takeExtension, (</>))+++-- Resolved tag file path+data TagsAtRoot = TagsAtProjectRoot FilePath+                | TagsAtPackageRoot FilePath+  deriving (Show, Eq)+++-- | Resolve an output path from the compiler's working directory and optional+-- STACK_YAML setting. A fallback directory is returned when no project+-- configuration was found, so the caller can report a warning.+resolveTagsFile :: FilePath+                -- ^ current working directory+                -> Maybe FilePath+                -- ^ `stack.yaml` absolute path (read from `STACK_YAML`+                -- variable)+                -> FilePath+                -- ^ user supplied tags file path+                -> IO TagsAtRoot+                -- ^ tuple of resolved patch and a fallback +resolveTagsFile _ _ path | isAbsolute path = pure (TagsAtProjectRoot path)+resolveTagsFile cwd stackYaml path = do+    start <- canonicalizePath cwd+    stackRoot <- case stackYaml of+      Just config | not (null config) -> do+        let configPath = cwd </> config+        exists <- doesFileExist configPath+        if exists+          then Just . takeDirectory <$> canonicalizePath configPath+          else pure Nothing+      _ -> pure Nothing+    case stackRoot of+      Just root -> pure (TagsAtProjectRoot $ normalise (root </> path))+      Nothing -> search start Nothing start+  where+    search start packageRoot dir = do+      configs <- traverse (doesFileExist . (dir </>))+                   [ "cabal.project"+                   , "cabal.project.local"+                   , "stack.yaml"+                   ]+      if or configs+        -- found project config+        then pure (TagsAtProjectRoot $ normalise (dir </> path))+        else do+          -- look for `*.cabal` files+          packageRoot' <- case packageRoot of+            Just _ -> pure packageRoot+            Nothing -> do+              entries <- listDirectory dir+              packages <- traverse (doesFileExist . (dir </>))+                (filter ((== ".cabal") . takeExtension) entries)+              pure $ if or packages then Just dir else Nothing+          let parent = takeDirectory dir+          if parent == dir+            then do+              -- We reached file system root directory, resolve tags file+              -- relative to last found package root.+              let root = fromMaybe start packageRoot'+              pure (TagsAtPackageRoot $ normalise (root </> path))+            else+              -- continue at the parent directory+              search start packageRoot' parent

@@ -0,0 +1,125 @@+{-# LANGUAGE NamedFieldPuns #-}++-- | Debug-only wall-clock measurements. Nested phases are charged separately.+module Plugin.GhcTags.Timing+  ( Timings+  , Phase (..)+  , TimingReport (..)+  , withTimings+  , withTimingsUsing+  , formatTimings+  , timed+  , timedNF+  , timedProducer+  , timedLock+  ) where++import Control.DeepSeq (NFData, force, rnf)+import Control.Exception (evaluate)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.IORef+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Word (Word64)+import GHC.Clock (getMonotonicTimeNSec)+import qualified Pipes+import Text.Printf (printf)+++data Phase = LockWait | ReadTags | ParseTags | GenerateTags | MergeTags | WriteTags+  deriving (Eq, Ord, Show, Enum, Bounded)++data Timings = Disabled | Enabled (IO Word64) (IORef (Map Phase Word64))++data TimingReport = TimingReport+  { totalNanos :: Word64+  , phaseNanos :: Map Phase Word64+  } deriving (Eq, Show)+++withTimings :: Bool -> (TimingReport -> IO ()) -> (Timings -> IO a) -> IO a+withTimings = withTimingsUsing getMonotonicTimeNSec+++-- | Injectable clock for deterministic tests. Reports completed updates only.+withTimingsUsing :: IO Word64 -> Bool -> (TimingReport -> IO ()) -> (Timings -> IO a) -> IO a+withTimingsUsing _ False _ action = action Disabled+withTimingsUsing clock True report action = do+    phases <- newIORef $ Map.fromList [(phase, 0) | phase <- [minBound .. maxBound]]+    start <- clock+    result <- action (Enabled clock phases)+    end <- clock+    elapsed <- readIORef phases+    report (TimingReport (end - start) elapsed)+    pure result+++-- | Measure an action, subtracting time already charged to nested phases.+-- The action's result must be forced by the caller if evaluating it is part+-- of the measured work. No clocks or counters are used when disabled.+timed :: MonadIO m => Timings -> Phase -> m a -> m a+timed Disabled _ action = action+timed (Enabled clock phases) phase action = do+    before <- liftIO $ Map.foldl' (+) 0 <$> readIORef phases+    start <- liftIO clock+    result <- action+    end <- liftIO clock+    after <- liftIO $ Map.foldl' (+) 0 <$> readIORef phases+    liftIO $ addTime phases phase (end - start - (after - before))+    pure result+++timedNF :: NFData a => Timings -> Phase -> IO a -> IO a+timedNF Disabled _ action = action+timedNF timings phase action = timed timings phase (action >>= evaluate . force)+++-- | Time each pull, excluding downstream consumers and charging upstream+-- timed producers to their own phases. Retains streaming space usage.+timedProducer :: (MonadIO m, NFData a)+              => Timings -> Phase -> Pipes.Producer a m r -> Pipes.Producer a m r+timedProducer Disabled _ producer = producer+timedProducer timings phase producer = do+    next <- Pipes.lift $ timed timings phase $ do+      result <- Pipes.next producer+      case result of+        Left _ -> pure ()+        Right (value, _) -> liftIO (evaluate $ rnf value)+      pure result+    case next of+      Left result -> pure result+      Right (value, rest) -> Pipes.yield value >> timedProducer timings phase rest+++-- | Measure only acquisition, not the protected action or lock release.+timedLock :: Timings+          -> (IO a -> IO a)+          -- ^ with lock combinator+          -> IO a+          -> IO a+timedLock Disabled withLock action = withLock action+timedLock (Enabled clock phases) withLock action = do+    start <- clock+    withLock $ do+      acquired <- clock+      addTime phases LockWait (acquired - start)+      action+++addTime :: IORef (Map Phase Word64) -> Phase -> Word64 -> IO ()+addTime phases phase elapsed =+    modifyIORef' phases (Map.insertWith (+) phase elapsed)+++formatTimings :: TimingReport -> String+formatTimings TimingReport {totalNanos, phaseNanos} =+    unwords ("timing:" : milliseconds "total" totalNanos+                      : [milliseconds (name phase) elapsed | (phase, elapsed) <- Map.toAscList phaseNanos])+  where+    milliseconds label nanos = printf "%s=%.3fms" label (fromIntegral nanos / 1000000 :: Double)+    name LockWait = "lock-wait"+    name ReadTags = "read"+    name ParseTags = "parse"+    name GenerateTags = "generate"+    name MergeTags = "merge"+    name WriteTags = "write"

@@ -0,0 +1,111 @@+module Test.AtomicFile (tests) where++import Control.Concurrent+import Control.Exception+import System.Directory+import System.FilePath ((</>))+import System.IO++import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit++import Plugin.GhcTags.AtomicFile++tests :: TestTree+tests = testGroup "Atomic file updates"+    [ testCase "aborted initial update leaves no files" testAbortedInitialUpdate+    , testCase "successful update publishes replacement" testSuccessfulUpdate+    , testCase "aborted update preserves existing tags" testAbortedUpdate+    , testCase "write exception preserves existing tags" testWriteException+    , testCase "cancellation preserves tags and permits the next update" testCancellation+    ]+++testAbortedInitialUpdate :: Assertion+testAbortedInitialUpdate = withTestDirectory $ \dir -> do+    withAtomicFile (dir </> "tags") $ \h ->+      hPutStr h "discarded\n" >> pure False+    listDirectory dir >>= (@?= [])+++testSuccessfulUpdate :: Assertion+testSuccessfulUpdate = withTagsFile $ \dir path -> do+    withAtomicFile path $ \h -> hPutStr h "replacement\n" >> pure True+    checkTagsFile dir path "replacement\n"+++testAbortedUpdate :: Assertion+testAbortedUpdate = withTagsFile $ \dir path -> do+    withAtomicFile path $ \h -> hPutStr h "partial\n" >> pure False+    checkTagsFile dir path original+++testWriteException :: Assertion+testWriteException = withTagsFile $ \dir path -> do+    result <- try $ withAtomicFile path $ \h -> do+      hPutStr h "partial\n"+      hFlush h+      throwIO (userError "write failed")+    case result :: Either IOException () of+      Left _ -> pure ()+      Right _ -> assertFailure "write exception swallowed"+    checkTagsFile dir path original+++testCancellation :: Assertion+testCancellation = withTagsFile $ \dir path -> do+    -- Cancel after partial output has reached the temporary file.+    started <- newEmptyMVar+    blocker <- newEmptyMVar :: IO (MVar ())+    finished <- newEmptyMVar+    let writer = do+          outcome <- try $ withAtomicFile path $ \h -> do+            hPutStr h "partial\n"+            hFlush h+            putMVar started ()+            takeMVar blocker+            pure True+          putMVar finished (outcome :: Either SomeException ())+    bracket (forkIO writer) killThread $ \tid -> do+      takeMVar started+      -- Readers see complete old contents while the update is in progress.+      readFile path >>= (@?= original)+      throwTo tid ThreadKilled+      outcome <- takeMVar finished+      case outcome of+        Left err -> fromException err @?= Just ThreadKilled+        Right _ -> assertFailure "cancellation swallowed"+      checkTagsFile dir path original+      withAtomicFile path $ \h -> hPutStr h "recovered\n" >> pure True+      checkTagsFile dir path "recovered\n"+++--+-- Utils+--++original :: String+original = "existing tags\n"+++withTestDirectory :: (FilePath -> IO a) -> IO a+withTestDirectory action = do+    tmp <- getTemporaryDirectory+    bracket (do (path, h) <- openTempFile tmp "ghc-tags-atomic-test"+                hClose h+                removeFile path+                createDirectory path+                pure path)+            removeDirectoryRecursive+            action++withTagsFile :: (FilePath -> FilePath -> IO a) -> IO a+withTagsFile action = withTestDirectory $ \dir -> do+    let path = dir </> "tags"+    writeFile path original+    action dir path++checkTagsFile :: FilePath -> FilePath -> String -> Assertion+checkTagsFile dir path expected = do+    readFile path >>= (@?= expected)+    listDirectory dir >>= (@?= ["tags"])

@@ -0,0 +1,199 @@+{-# LANGUAGE NamedFieldPuns    #-}+{-# LANGUAGE OverloadedStrings #-}++module Test.Check (tests) where++import Control.Monad (forM_)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BSC+import Data.Char (isControl)+import Data.List ((\\), group, nub, sort)+import qualified Data.Map.Strict as Map+import Data.Maybe (mapMaybe)+import qualified Data.Text as Text+import System.Directory (canonicalizePath, createDirectory, createDirectoryIfMissing)+import System.FilePath (joinPath, splitDirectories, takeDirectory, (</>))+import System.IO.Temp (withSystemTempDirectory)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.QuickCheck+import Test.QuickCheck.Instances.ByteString ()+import Test.QuickCheck.Instances.Text ()++import GhcTags.Check+++tests :: TestTree+tests = testGroup "Check"+  [ testProperty "duplicate declarations match grouped locations" duplicatesProp+  , testProperty "comparison matches list multiset difference" comparisonProp+  , testProperty "source line count matches splitting into lines" sourceLinesProp+  , testProperty "source diagnostics match the generated files" sourceChecksProp+  , testProperty "source paths are relative to each tags file" relativePathsProp+  ]+++newtype ArbLocation = ArbLocation { getTagLocation :: TagLocation }+  deriving Show++instance Arbitrary ArbLocation where+    arbitrary = fmap ArbLocation $ TagLocation+      <$> elements sourcePaths+      <*> frequency [ (5, Just <$> choose (-2, 8))+                    , (1, pure Nothing)+                    ]+      <*> frequency [ (4, elements ["foo", "bar", "baz"])+                    , (1, fixName <$> arbitrary)+                    ]+    shrink (ArbLocation tag@TagLocation {sourceLine, sourceName}) =+         [ArbLocation tag {sourceLine = line} | line <- shrink sourceLine]+      ++ [ ArbLocation tag {sourceName = name}+         | name <- map fixName $ shrink sourceName+         , name /= sourceName+         ]+++fixName :: Text.Text -> Text.Text+fixName name = case Text.filter (not . isControl) name of+    "" -> "a"+    valid -> valid+++sourcePaths :: [FilePath]+sourcePaths = ["A.hs", "source with spaces/B.hs", "sub/C.hs"]+++newtype Locations = Locations [TagLocation]+  deriving Show++instance Arbitrary Locations where+    arbitrary = Locations . map getTagLocation <$> resize 30 arbitrary+    shrink (Locations tags) = map Locations $ shrinkList+      (\tag -> [smaller | ArbLocation smaller <- shrink (ArbLocation tag)]) tags+++modelDeclarations :: [TagLocation] -> [Declaration]+modelDeclarations =+    mapMaybe $+      \TagLocation {sourcePath, sourceLine, sourceName} ->+      (\line -> Declaration sourcePath line sourceName) <$> sourceLine+++duplicatesProp :: Locations -> Property+duplicatesProp (Locations tags) =+    let groups = group $ sort $ modelDeclarations tags+        expected = [(location, length locations) | locations@(location : _ : _) <- groups]+    in Map.toAscList (duplicateDeclarations tags) === expected+++comparisonProp :: Locations -> Locations -> Property+comparisonProp (Locations left) (Locations right) =+    let a = modelDeclarations left+        b = modelDeclarations right+        expected = (sort $ a \\ b, sort $ b \\ a)+        (onlyLeft, onlyRight) = compareDeclarations left right+        expand counts = concat [replicate count location | (location, count) <- Map.toAscList counts]+    in (expand onlyLeft, expand onlyRight) === expected+++newtype Contents = Contents BS.ByteString+  deriving Show++instance Arbitrary Contents where+    arbitrary = Contents <$> frequency+      [ (2, arbitrary)+      , (1, pure BS.empty)+      , (3, BS.intercalate "\n" <$> resize 6 arbitrary)+      , (1, (<> "\n") <$> arbitrary)+      ]+    shrink (Contents bytes) = map Contents $ shrink bytes+++sourceLinesProp :: Contents -> Property+sourceLinesProp (Contents bytes) = countSourceLines bytes === length (BSC.lines bytes)+++data SourceFile = MissingFile | ReadableFile BS.ByteString | SourceDirectory+  deriving (Eq, Show)++instance Arbitrary SourceFile where+    arbitrary = frequency+      [ (2, pure MissingFile)+      , (5, (\(Contents bytes) -> ReadableFile bytes) <$> arbitrary)+      , (1, pure SourceDirectory)+      ]+++data SourceExample = SourceExample+  { sourceFiles :: Map.Map FilePath SourceFile+  , sourceTags :: Locations+  }+  deriving Show++instance Arbitrary SourceExample where+    arbitrary = SourceExample+      <$> (Map.fromList <$> resize 6 (listOf $ (,)+            <$> elements sourcePaths+            <*> arbitrary))+      <*> arbitrary+    shrink SourceExample {sourceFiles, sourceTags} =+         [ SourceExample (Map.fromList smaller) sourceTags+         | smaller <- shrinkList (const []) (Map.toList sourceFiles)+         ]+      ++ [SourceExample sourceFiles smaller | smaller <- shrink sourceTags]+++sourceChecksProp :: SourceExample -> Property+sourceChecksProp SourceExample {sourceFiles, sourceTags = Locations tags} = ioProperty $+    withSystemTempDirectory "gtp-check-sources" $ \root -> do+      forM_ (Map.toList sourceFiles) $ \(path, contents) ->+        case contents of+          MissingFile -> pure ()+          ReadableFile bytes -> do+            createDirectoryIfMissing True (takeDirectory $ root </> path)+            BS.writeFile (root </> path) bytes+          SourceDirectory -> do+            createDirectoryIfMissing True (takeDirectory $ root </> path)+            createDirectory (root </> path)+      let absoluteTags = [tag {sourcePath = root </> sourcePath tag} | tag <- tags]+          paths = sort $ nub $ map sourcePath tags+          expectedMissing =+            [root </> path | path <- paths, Map.lookup path sourceFiles `elem` [Nothing, Just MissingFile]]+          expectedUnreadable =+            [root </> path | path <- paths, Map.lookup path sourceFiles == Just SourceDirectory]+          expectedInvalid =+            [ (Declaration (root </> path) line name, length $ BSC.lines bytes)+            | Declaration path line name <- sort $ nub $ modelDeclarations tags+            , Just (ReadableFile bytes) <- [Map.lookup path sourceFiles]+            , line < 1 || line > length (BSC.lines bytes)+            ]+          expected = (expectedMissing, expectedUnreadable, expectedInvalid)+      actual <- checkSources absoluteTags+      pure $ (missingSources actual, map fst $ unreadableSources actual, invalidLines actual) === expected+++data PathExample = PathExample FilePath FilePath+  deriving Show++instance Arbitrary PathExample where+    arbitrary = PathExample+      <$> (joinPath . ("sources" :) <$> resize 4 (listOf segment))+      <*> (joinPath . ("output" :) <$> resize 4 (listOf segment))+      where+        segment = elements ["a", "b", "directory with spaces"]+++relativePathsProp :: PathExample -> Property+relativePathsProp (PathExample sourceDir tagsDir) = ioProperty $+    withSystemTempDirectory "gtp-check-paths" $ \root -> do+      let source = root </> sourceDir </> "A.hs"+          output = root </> tagsDir+          relative = joinPath (replicate (length $ splitDirectories tagsDir) "..")+                   </> sourceDir </> "A.hs"+          tag = TagLocation source (Just 1) "foo"+      createDirectoryIfMissing True (takeDirectory source)+      createDirectoryIfMissing True output+      BS.writeFile source "foo = ()\n"+      expected <- canonicalizePath source+      fromRelative <- resolveTagPaths output [tag {sourcePath = relative}]+      fromAbsolute <- resolveTagPaths root [tag]+      pure $ (fromRelative, fromAbsolute) === ([tag {sourcePath = expected}], [tag {sourcePath = expected}])

@@ -0,0 +1,206 @@+{-# LANGUAGE CPP            #-}+{-# LANGUAGE NamedFieldPuns  #-}++{-# OPTIONS_GHC -Wno-orphans #-}++module Test.Ghc (tests) where++import qualified Data.ByteString.Char8 as BSC+import Data.Foldable (toList)+import Data.List (sort)+import GHC.Hs+import GHC.Types.Name.Occurrence (occNameString)+import GHC.Types.Name.Reader (rdrNameOcc)+import GHC.Types.SrcLoc (GenLocated (..), unLoc)+import qualified GHC.Utils.Outputable as Out+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.QuickCheck++import GhcTags.Ghc+import Test.Ghc.Generators+++tests :: TestTree+tests = testGroup "Ghc"+    [ testProperty "pattern signature filtering follows the option within each binding group" patternSignatureProp+    , testProperty "method visibility follows class exports and lexical scope" methodExportsProp+    , testProperty "family tags follow declarations and exports" familyExportsProp+    ]++instance Arbitrary Filter where+  arbitrary = elements [RetainAll, RemoveTerms]+  shrink RetainAll   = [RemoveTerms]+  shrink RemoveTerms = []+  ++patternSignatureProp :: Filter -> [ArbHsDecl] -> Property+patternSignatureProp filterBindings input =+    let declarations = map getArbHsDecl input+        tags = hsDeclsToGhcTags filterBindings Nothing declarations+        actual =+          [ (BSC.unpack gtTag, kind, signatureType)+          | GhcTag {gtTag, gtKind} <- tags+          , let (kind, signatureType) = case gtKind of+                  GtkTypeSignature ty ->+                    ("signature", Out.renderWithContext Out.defaultSDocContext $ Out.ppr ty)+                  GtkPatternSynonym -> ("pattern", "")+                  _ -> ("unexpected", "")+          ]+        declarationsModel = concatMap (\decl -> case unLoc decl of+          SigD _ (PatSynSig _ names signature) ->+            [ (occNameString $ rdrNameOcc $ unLoc name, "signature",+               Out.renderWithContext Out.defaultSDocContext $ Out.ppr signature)+            | name <- names+            ]+          ValD _ (PatSynBind _ PSB {psb_id}) ->+            [(occNameString $ rdrNameOcc $ unLoc psb_id, "pattern", "")]+          _ -> []) declarations+        signatures = [name | (name, "signature", _) <- declarationsModel]+        definitions = [name | (name, "pattern", _) <- declarationsModel]+        expected =+          filter+            (\(name, kind, _) -> filterBindings == RetainAll+                              || kind /= "pattern"+                              || name `notElem` signatures)+          declarationsModel+    in checkCoverage+       $ cover 25 (filterBindings == RemoveTerms) "filtering enabled"+       $ cover 25 (filterBindings == RetainAll) "filtering disabled"+       $ cover 30 (not (null signatures) && not (null definitions)) "signatures and definitions"+       $ cover 20 (any (`elem` definitions) signatures) "matching signature and definition names"+       $ cover 20 (any (`notElem` signatures) definitions) "unsigned pattern definitions"+       $ actual === expected+++methodExportsProp :: ArbClassModule -> Property+methodExportsProp (ArbClassModule ast@(L _ HsModule {hsmodDecls, hsmodExports})) =+    let nameOf = occNameString . rdrNameOcc . unLoc+        wrappedName = occNameString . rdrNameOcc . ieWrappedName . unLoc+        classes =+          [ (nameOf tcdLName, map nameOf $ concatMap (signatureNames . unLoc) tcdSigs)+          | L _ (TyClD _ ClassDecl {tcdLName, tcdSigs}) <- hsmodDecls+          ]+        membersOf className = concat [names | (name, names) <- classes, name == className]+        exportedMembers :: IE GhcPs -> [String]+        exportedMembers ie = case ie of+#if MIN_VERSION_GLASGOW_HASKELL(9,10,0,0)+          IEVar _ name _ -> [wrappedName name]+          IEThingAll _ name _ -> membersOf (wrappedName name)+          IEThingWith _ name wildcard children _ ->+#else+          IEVar _ name -> [wrappedName name]+          IEThingAll _ name -> membersOf (wrappedName name)+          IEThingWith _ name wildcard children ->+#endif+            case wildcard of+              IEWildcard {} -> membersOf (wrappedName name)+              NoIEWildcard -> filter (`elem` map wrappedName children) (membersOf $ wrappedName name)+          _ -> []+        publicNames = case hsmodExports of+          Nothing -> concatMap snd classes+          Just exports -> concatMap (exportedMembers . unLoc) (unLoc exports)+        directNames = concatMap (\decl -> case unLoc decl of+          TyClD _ ClassDecl {tcdSigs, tcdMeths} ->+               concatMap (signatureNames . unLoc) tcdSigs+            ++ [fun_id | L _ FunBind {fun_id} <- toList tcdMeths]+          InstD _ (ClsInstD _ ClsInstDecl {cid_sigs, cid_binds}) ->+               concatMap (signatureNames . unLoc) cid_sigs+            ++ [fun_id | L _ FunBind {fun_id} <- toList cid_binds]+          _ -> []) hsmodDecls+        publicLocations = [getLocA name | name <- directNames, nameOf name `elem` publicNames]+        directLocations = map getLocA directNames+        tags = filter (\tag -> case gtKind tag of+                         GtkModule -> False+                         GtkTypeClass -> False+                         GtkTypeClassInstance {} -> False+                         _ -> True) (getGhcTags RetainAll ast)+        expected = [gtSrcSpan tag `elem` publicLocations | tag <- tags]+        shadowsExport = any (\tag -> BSC.unpack (gtTag tag) `elem` publicNames+                                 && gtSrcSpan tag `notElem` directLocations) tags+    in checkCoverage+       $ cover 20 (not $ null publicLocations) "exported methods"+       $ cover 20 (any ((`notElem` publicNames) . nameOf) directNames) "hidden methods"+       $ cover 10 shadowsExport "local bindings shadow exported methods"+       $ counterexample (show [(BSC.unpack $ gtTag tag, gtSrcSpan tag) | tag <- tags])+       $ map gtIsExported tags === expected+  where+    signatureNames :: Sig GhcPs -> [LIdP GhcPs]+    signatureNames (ClassOpSig _ _ names _) = names+    signatureNames (TypeSig _ names _) = names+    signatureNames _ = []+++familyExportsProp :: ArbFamilyModule -> Property+familyExportsProp (ArbFamilyModule ast@(L _ HsModule {hsmodDecls, hsmodExports})) =+    let nameOf = occNameString . rdrNameOcc . unLoc+        wrappedName = occNameString . rdrNameOcc . ieWrappedName . unLoc+        typeInstanceName :: TyFamInstDecl GhcPs -> LIdP GhcPs+        typeInstanceName TyFamInstDecl {tfid_eqn = FamEqn {feqn_tycon}} = feqn_tycon+        dataInstanceNames :: DataFamInstDecl GhcPs -> ([LIdP GhcPs], [(String, [String])])+        dataInstanceNames DataFamInstDecl {dfid_eqn = FamEqn {feqn_tycon, feqn_rhs = HsDataDefn {dd_cons}}} =+          let children = concatMap (constructorNames . unLoc) dd_cons+          in (feqn_tycon : children, [(nameOf feqn_tycon, map nameOf children)])+        declarations = map (\decl -> case unLoc decl of+          TyClD _ (FamDecl _ FamilyDecl {fdLName}) -> ([fdLName], [])+          TyClD _ ClassDecl {tcdLName, tcdATs, tcdATDefs} ->+            let members = [fdLName | L _ FamilyDecl {fdLName} <- tcdATs]+            in (members ++ map (typeInstanceName . unLoc) tcdATDefs,+                [(nameOf tcdLName, map nameOf members)])+          InstD _ (TyFamInstD _ decl') -> ([typeInstanceName decl'], [])+          InstD _ (DataFamInstD _ decl') -> dataInstanceNames decl'+          InstD _ (ClsInstD _ ClsInstDecl {cid_tyfam_insts, cid_datafam_insts}) ->+            let dataInstances = map (dataInstanceNames . unLoc) cid_datafam_insts+            in (map (typeInstanceName . unLoc) cid_tyfam_insts ++ concatMap fst dataInstances,+                concatMap snd dataInstances)+          _ -> ([], [])) hsmodDecls+        names = concatMap fst declarations+        childrenOf parent = concat [children | (_, edges) <- declarations,+                                               (name, children) <- edges, name == parent]+        expandExport :: IE GhcPs -> [String]+        expandExport ie = case ie of+#if MIN_VERSION_GLASGOW_HASKELL(9,10,0,0)+          IEVar _ name _ -> [wrappedName name]+          IEThingAbs _ name _ -> [wrappedName name]+          IEThingAll _ name _ -> wrappedName name : childrenOf (wrappedName name)+          IEThingWith _ name wildcard children _ ->+#else+          IEVar _ name -> [wrappedName name]+          IEThingAbs _ name -> [wrappedName name]+          IEThingAll _ name -> wrappedName name : childrenOf (wrappedName name)+          IEThingWith _ name wildcard children ->+#endif+            wrappedName name : case wildcard of+              IEWildcard {} -> childrenOf (wrappedName name)+              NoIEWildcard -> map wrappedName children+          _ -> []+        publicNames = case hsmodExports of+          Nothing -> map nameOf names+          Just exports -> concatMap (expandExport . unLoc) (unLoc exports)+        expected = sort [(nameOf name, show $ getLocA name, nameOf name `elem` publicNames) | name <- names]+        tags = filter (\tag -> case gtKind tag of+                         GtkModule -> False+                         GtkTypeClass -> False+                         GtkTypeClassInstance {} -> False+                         _ -> True) (getGhcTags RetainAll ast)+        actual = sort [(BSC.unpack gtTag, show gtSrcSpan, gtIsExported) | GhcTag {gtTag, gtSrcSpan, gtIsExported} <- tags]+        hasDefault = or [not (null tcdATDefs) | L _ (TyClD _ ClassDecl {tcdATDefs}) <- hsmodDecls]+        hiddenChildren = or [parent `elem` publicNames && any (`notElem` publicNames) children+                            | (_, edges) <- declarations, (parent, children) <- edges]+    in checkCoverage+       $ cover 20 (any ((`elem` publicNames) . nameOf) names) "exported families or members"+       $ cover 10 (any ((`notElem` publicNames) . nameOf) names) "hidden families or members"+       $ cover 10 hasDefault "associated type defaults"+       $ cover 10 hiddenChildren "exported parents with hidden members"+       $ actual === expected+  where+    constructorNames :: ConDecl GhcPs -> [LIdP GhcPs]+    constructorNames ConDeclH98 {con_name, con_args} =+      con_name : case con_args of+        RecCon (L _ fields) ->+#if MIN_VERSION_GLASGOW_HASKELL(9,14,0,0)+          [foLabel field | L _ HsConDeclRecField {cdrf_names} <- fields, L _ field <- cdrf_names]+#else+          [foLabel field | L _ ConDeclField {cd_fld_names} <- fields, L _ field <- cd_fld_names]+#endif+        _ -> []+    constructorNames _ = []

@@ -0,0 +1,252 @@+{-# LANGUAGE CPP            #-}+{-# LANGUAGE NamedFieldPuns #-}++module Test.Ghc.Generators (ArbHsDecl (..), ArbClassModule (..), ArbFamilyModule (..)) where++import Data.Char (isUpper)+import Data.List (intercalate)+import qualified GHC.Data.EnumSet as EnumSet+import GHC.Data.FastString (mkFastString)+import GHC.Data.StringBuffer (stringToStringBuffer)+import GHC.Hs+import GHC.LanguageExtensions.Type (Extension (TypeFamilies, ExplicitNamespaces))+import qualified GHC.Parser as Parser+import GHC.Parser.Lexer (ParseResult (..), initParserState, mkParserOpts, unP)+import GHC.Types.Name.Occurrence (mkDataOcc, mkOccName, mkTcOcc, occNameSpace, occNameString)+import GHC.Types.Name.Reader (RdrName, mkRdrUnqual, rdrNameOcc)+import GHC.Types.SrcLoc (GenLocated (..), Located, mkRealSrcLoc, unLoc)+#if MIN_VERSION_GLASGOW_HASKELL(9,8,0,0)+import GHC.Utils.Error (emptyDiagOpts)+#else+import GHC.Utils.Error (DiagOpts (..))+#endif+import qualified GHC.Utils.Outputable as Out+import Test.Tasty.QuickCheck+++newtype ArbHsDecl = ArbHsDecl { getArbHsDecl :: LHsDecl GhcPs }++instance Show ArbHsDecl where+    show = Out.renderWithContext Out.defaultSDocContext . Out.ppr . getArbHsDecl++instance Arbitrary ArbHsDecl where+    arbitrary = oneof+      [ patternSignature <$> arbitrary <*> arbitrary+      , patternDefinition <$> arbitrary+      ]+    shrink (ArbHsDecl decl) = map ArbHsDecl $ case unLoc decl of+      SigD ext sig -> [fmap (const $ SigD ext smaller) decl | smaller <- shrinkSignature sig]+      ValD ext bind -> [fmap (const $ ValD ext smaller) decl | smaller <- shrinkBinding bind]+      _ -> []+++newtype ConstructorName = ConstructorName String+  deriving Show++instance Arbitrary ConstructorName where+    arbitrary = ConstructorName <$> frequency+      [ (3, elements ["Done", "Yield", "Await"])+      , (1, fixConstructorName <$>+          listOf (elements (['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_")))+      ]+    shrink (ConstructorName name) =+      [ ConstructorName smaller+      | smaller <- map fixConstructorName (shrink name)+      , (length smaller, smaller) < (length name, name)+      ]+++fixConstructorName :: String -> String+fixConstructorName name =+    let valid = filter (`elem` (['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_")) name+    in case valid of+      first : _ | isUpper first -> valid+      _ -> 'P' : valid+++patternSignature :: ConstructorName -> ConstructorName -> ArbHsDecl+patternSignature (ConstructorName name) (ConstructorName typeName) =+    let readerName = noLocA (mkRdrUnqual $ mkDataOcc name)+        hsType = noLocA (HsTyVar noAnn NotPromoted+                          (noLocA $ mkRdrUnqual $ mkTcOcc typeName))+    in ArbHsDecl $ noLocA $ SigD noExtField $+         PatSynSig noAnn [readerName] (noLocA $ mkHsImplicitSigType hsType)+++patternDefinition :: ConstructorName -> ArbHsDecl+patternDefinition (ConstructorName name) =+    ArbHsDecl $ noLocA $ ValD noExtField $ PatSynBind noExtField PSB+      { psb_ext = noAnn+      , psb_id = noLocA (mkRdrUnqual $ mkDataOcc name)+#if MIN_VERSION_GLASGOW_HASKELL(9,14,0,0)+      , psb_args = PrefixCon []+#else+      , psb_args = PrefixCon [] []+#endif+      , psb_def = noLocA (WildPat noExtField)+      , psb_dir = Unidirectional+      }+++shrinkSignature :: Sig GhcPs -> [Sig GhcPs]+shrinkSignature (PatSynSig ext names sigType) =+     [PatSynSig ext names' sigType | names' <- shrinkList shrinkName names, not (null names')]+  ++ [PatSynSig ext names sigType' | sigType' <- shrinkSignatureType sigType]+shrinkSignature _ = []+++shrinkSignatureType :: LHsSigType GhcPs -> [LHsSigType GhcPs]+shrinkSignatureType (L loc sig@HsSig {sig_body = L bodyLoc (HsTyVar ext promotion name)}) =+    [ L loc sig {sig_body = L bodyLoc (HsTyVar ext promotion smaller)}+    | smaller <- shrinkName name+    ]+shrinkSignatureType _ = []+++shrinkBinding :: HsBind GhcPs -> [HsBind GhcPs]+shrinkBinding (PatSynBind ext psb@PSB {psb_id}) =+    [PatSynBind ext psb {psb_id = smaller} | smaller <- shrinkName psb_id]+shrinkBinding _ = []+++shrinkName :: GenLocated loc RdrName -> [GenLocated loc RdrName]+shrinkName name =+    let occurrence = rdrNameOcc (unLoc name)+    in [ fmap (const $ mkRdrUnqual $ mkOccName (occNameSpace occurrence) smaller) name+       | ConstructorName smaller <- shrink (ConstructorName $ occNameString occurrence)+       ]+++-- Parsed modules keep real source locations, including distinct locations for+-- local bindings which shadow class methods.+newtype ArbClassModule = ArbClassModule { getArbClassModule :: Located (HsModule GhcPs) }++instance Show ArbClassModule where+    show = Out.renderWithContext Out.defaultSDocContext . Out.ppr . getArbClassModule++instance Arbitrary ArbClassModule where+    arbitrary = do+      ConstructorName classSuffix <- arbitrary+      methodSuffixes <- resize 5 arbitrary+      let className = "Class" ++ classSuffix+          methods = ["method" ++ name ++ show i | (i, ConstructorName name) <- zip [0 :: Int ..] methodSuffixes]+      selected <- sublistOf methods+      exports <- elements+        [ ""+        , "()"+        , "(" ++ className ++ "(..))"+        , "(" ++ className ++ "(" ++ intercalate "," selected ++ "))"+        , "(" ++ intercalate "," selected ++ ")"+        , "(" ++ className ++ ")"+        , "(Eq(..))"+        ]+      defaults <- mapM methodBinding methods+      instances <- mapM (\name -> do+        signature <- elements ["", "  " ++ name ++ " :: Int -> ()\n"]+        binding <- methodBinding name+        pure (signature ++ binding)) methods+      pure $ ArbClassModule $ parseModule $+           "module Example " ++ exports ++ " where\n"+        ++ "class " ++ className ++ " a where\n"+        ++ concat ["  " ++ name ++ " :: a -> ()\n" | name <- methods]+        ++ concat defaults+        ++ "instance " ++ className ++ " Int where\n"+        ++ concat instances+    shrink (ArbClassModule ast@(L _ HsModule {hsmodExports})) =+      [ ArbClassModule (fmap (\mod_ -> mod_ {hsmodExports = smaller}) ast)+      | smaller <- case hsmodExports of+          Nothing -> [Just $ noLocA []]+          Just exports ->+            [Just (fmap (const entries) exports) | entries <- shrinkList (const []) (unLoc exports)]+      ]+++methodBinding :: String -> Gen String+methodBinding name = do+    helper <- elements [name, "local" ++ name]+    signature <- elements ["", "      " ++ helper ++ " :: b -> ()\n"]+    pure $ "  " ++ name ++ " x = " ++ helper ++ " x\n"+        ++ "    where\n"+        ++ signature+        ++ "      " ++ helper ++ " _ = ()\n"+++#if !MIN_VERSION_GLASGOW_HASKELL(9,8,0,0)+emptyDiagOpts :: DiagOpts+emptyDiagOpts = DiagOpts+  { diag_warning_flags       = EnumSet.empty+  , diag_fatal_warning_flags = EnumSet.empty+  , diag_warn_is_error       = False+  , diag_reverse_errors      = False+  , diag_max_errors          = Nothing+  , diag_ppr_ctx             = Out.defaultSDocContext+  }+#endif+++parseModule :: String -> Located (HsModule GhcPs)+parseModule source =+    case unP Parser.parseModule (initParserState options (stringToStringBuffer source) location) of+      POk _ ast -> ast+      PFailed _ -> error ("Invalid generated module:\n" ++ source)+  where+    location = mkRealSrcLoc (mkFastString "Example.hs") 1 1+    options = mkParserOpts (EnumSet.fromList [TypeFamilies, ExplicitNamespaces]) emptyDiagOpts+#if !MIN_VERSION_GLASGOW_HASKELL(9,14,0,0)+                []+#endif+                False False False False+++newtype ArbFamilyModule = ArbFamilyModule { getArbFamilyModule :: Located (HsModule GhcPs) }++instance Show ArbFamilyModule where+    show = Out.renderWithContext Out.defaultSDocContext . Out.ppr . getArbFamilyModule++instance Arbitrary ArbFamilyModule where+    arbitrary = do+      ConstructorName suffix <- arbitrary+      familySuffixes <- resize 4 arbitrary+      let className = "Class" ++ suffix+      families <- mapM (\(i, ConstructorName name) -> do+        associated <- arbitrary+        withDefault <- arbitrary+        record <- arbitrary+        rhs <- elements ["Maybe a", "[a]", "(a, a)", "a"]+        let ty = "Type" ++ name ++ show i+            dat = "Data" ++ name ++ show i+            con = "Mk" ++ dat+            field = "field" ++ dat+            declaration = ["type " ++ ty ++ " a", "data " ++ dat ++ " a"]+            def = ["type " ++ ty ++ " a = " ++ rhs | withDefault]+            equations = [ "type " ++ ty ++ " Int = Bool"+                        , "data " ++ dat ++ " Int = " ++ con+                            ++ if record then " { " ++ field ++ " :: Int }" else " Int" ]+            standalone = ["type family " ++ ty ++ " a", "data family " ++ dat ++ " a",+                          "type instance " ++ ty ++ " Int = Bool",+                          "data instance " ++ dat ++ " Int = " ++ con+                            ++ if record then " { " ++ field ++ " :: Int }" else " Int"]+            exports = [ty, "type " ++ ty, dat, dat ++ "(..)", dat ++ "(" ++ con ++ ")"]+                   ++ [field | record]+                   ++ [dat ++ "(" ++ field ++ ")" | record]+                   ++ [className ++ "(" ++ member ++ ")" | associated, member <- [ty, dat]]+        pure (if associated then ([], declaration ++ def, equations, exports)+                            else (standalone, [], [], exports)))+        (zip [0 :: Int ..] familySuffixes)+      exports <- sublistOf ([className, className ++ "(..)", "Eq(..)"]+                        ++ concat [es | (_, _, _, es) <- families])+      exportList <- frequency [(1, pure ""), (4, pure $ "(" ++ intercalate "," exports ++ ")")]+      pure $ ArbFamilyModule $ parseModule $+           "module Example " ++ exportList ++ " where\n"+        ++ unlines (concat [ds | (ds, _, _, _) <- families])+        ++ "class " ++ className ++ " a where\n"+        ++ unlines ["  " ++ d | (_, ds, _, _) <- families, d <- ds]+        ++ "instance " ++ className ++ " Int where\n"+        ++ unlines ["  " ++ d | (_, _, ds, _) <- families, d <- ds]+    shrink (ArbFamilyModule ast@(L _ HsModule {hsmodExports})) =+      [ ArbFamilyModule (fmap (\mod_ -> mod_ {hsmodExports = smaller}) ast)+      | smaller <- case hsmodExports of+          Nothing -> [Just $ noLocA []]+          Just exports ->+            [Just (fmap (const entries) exports) | entries <- shrinkList (const []) (unLoc exports)]+      ]

@@ -0,0 +1,47 @@+module Test.Options (tests) where++import Data.Maybe (maybeToList)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.QuickCheck hiding (Success)++import Plugin.GhcTags.Options+++tests :: TestTree+tests = testGroup "Options"+    [ testProperty "filtering defaults on and accepts both disabling flags" filterOptionsProp ]++data FilterFlag = NoArg | LongArg | ShortArg+  deriving (Show, Eq)++instance Arbitrary FilterFlag where+  arbitrary = elements [NoArg, LongArg, ShortArg]+  shrink LongArg  = [ShortArg, NoArg]+  shrink ShortArg = [NoArg]+  shrink NoArg    = []+++filterFlagToFlag :: FilterFlag -> Maybe String+filterFlagToFlag LongArg  = Just "--no-filter"+filterFlagToFlag ShortArg = Just "-F"+filterFlagToFlag NoArg    = Nothing++filterFlagToFilter :: FilterFlag -> Filter+filterFlagToFilter LongArg  = RetainAll+filterFlagToFilter ShortArg = RetainAll+filterFlagToFilter NoArg    = RemoveTerms+++filterOptionsProp :: FilterFlag -> Property+filterOptionsProp flag =+    let args = maybeToList (filterFlagToFlag flag)+    in checkCoverage+       $ cover 10 (flag == NoArg) "default"+       $ cover 10 (flag == LongArg) "long flag"+       $ cover 10 (flag == ShortArg) "short flag"+       $ case runOptionParser args of+           Success options ->+             filterOption options+             ===+             filterFlagToFilter flag+           _ -> counterexample ("Failed to parse " ++ show args) False

@@ -0,0 +1,174 @@+{-# LANGUAGE NamedFieldPuns #-}++module Test.ProjectFile (tests) where++import Control.Exception (bracket)+import Control.Monad (filterM, forM_, when)+import Data.List (find, scanl')+import Data.Maybe (isJust)+import System.Directory+import System.FilePath ((</>), normalise, splitDirectories, takeDirectory, takeExtension)+import System.IO (hClose, openTempFile)++import Test.Tasty (TestTree, testGroup)+import Test.Tasty.QuickCheck++import Plugin.GhcTags.Project+++tests :: TestTree+tests = testGroup "ProjectFile"+    [ testProperty "project-relative tags path matches model" resolutionProp ]+++data ProjectConfig = CabalProject+                   | CabalProjectLocal+                   | StackConfig+  deriving (Eq, Show)++data DirectoryEntry = DirectoryEntry (Maybe ProjectConfig) Bool+  deriving (Eq, Show)++instance Arbitrary DirectoryEntry where+    arbitrary = DirectoryEntry+      <$> frequency+            [ (6, pure Nothing)+            , (1, pure (Just CabalProject))+            , (1, pure (Just CabalProjectLocal))+            , (1, pure (Just StackConfig))+            ]+      <*> arbitrary+    shrink (DirectoryEntry config package) =+         [ DirectoryEntry Nothing package | isJust config ]+      ++ [ DirectoryEntry config False | package ]+++data StackOverride = NoOverride+                   | ExistingOverride+                   | MissingOverride+  deriving (Eq, Show)++instance Arbitrary StackOverride where+    arbitrary = frequency+                  [ (6, pure NoOverride)+                  , (2, pure ExistingOverride)+                  , (1, pure MissingOverride)+                  ]+    shrink NoOverride = []+    shrink _ = [NoOverride]+++data ProjectLayout = ProjectLayout {+    levels         :: NonEmptyList DirectoryEntry,+    absoluteOutput :: Bool,+    stackOverride  :: StackOverride,+    relativeOutput :: FilePath+  }+  deriving Show++instance Arbitrary ProjectLayout where+    arbitrary = ProjectLayout+      <$> resize 6 arbitrary+      <*> frequency+            [ (7, pure False)+            , (1, pure True)+            ]+      <*> arbitrary+      <*> elements ["tags", "TAGS", "output/tags", "../tags"]+    shrink layout@ProjectLayout {levels, absoluteOutput, stackOverride} =+         [ layout { levels = levels' }+         | levels' <- shrink levels ]+      ++ [ layout { absoluteOutput = False }+         | absoluteOutput ]+      ++ [ layout { stackOverride = stackOverride' }+         | stackOverride' <- shrink stackOverride ]+++resolutionProp :: ProjectLayout -> Property+resolutionProp ProjectLayout {levels = NonEmpty entries, absoluteOutput, stackOverride, relativeOutput} =+    ioProperty $ withTestDirectory $ \root -> do+      let components = ["level" ++ show n | n <- [0 .. length entries - 1]]+          directories = drop 1 $ scanl' (</>) root components+          cwd = foldl (</>) root components+          overrideRoot = root </> "override"+          overrideFile = overrideRoot </> "custom-stack.yaml"+          override = case stackOverride of+            NoOverride -> Nothing+            _ -> Just overrideFile+          path = if absoluteOutput then root </> "absolute.tags" else relativeOutput+      createDirectoryIfMissing True cwd+      forM_ (zip directories entries) $ \(dir, DirectoryEntry config package) -> do+        forM_ config $ \kind -> writeFile (dir </> configName kind) ""+        when package $ writeFile (dir </> "package.cabal") ""+      when (stackOverride == ExistingOverride) $ do+        createDirectory overrideRoot+        writeFile overrideFile ""+      -- The resolver can leave the generated hierarchy. Include ambient+      -- directories in the model when no generated project marker stops it.+      ancestors <-+        if   absoluteOutput+          || stackOverride == ExistingOverride+          || any (\(DirectoryEntry config _) -> isJust config) entries+          then pure []+          else readAncestorEntries root+      actual <- resolveTagsFile cwd override path+      let -- Independent model: select the innermost matching directory from+          -- the generated hierarchy followed by its surrounding directories.+          innerFirst = reverse (zip directories entries) ++ ancestors+          project = fst <$> find (\(_, DirectoryEntry config _) -> isJust config) innerFirst+          package = fst <$> find (\(_, DirectoryEntry _ present) -> present) innerFirst++          fallback = maybe cwd id package++          expected :: TagsAtRoot+          expected+            | absoluteOutput+            = (TagsAtProjectRoot path)++            | ExistingOverride <- stackOverride+            = TagsAtProjectRoot (normalise (overrideRoot </> path))++            | Just dir <- project+            = TagsAtProjectRoot (normalise (dir </> path))++            | otherwise+            = TagsAtPackageRoot (normalise (fallback </> path))++      pure $+        classify absoluteOutput "absolute output" $+        classify (stackOverride == ExistingOverride) "explicit Stack configuration" $+        classify (stackOverride == MissingOverride) "missing Stack configuration" $+        classify (not absoluteOutput && stackOverride /= ExistingOverride && not (isJust project)) "fallback" $+          actual === expected+++configName :: ProjectConfig -> FilePath+configName CabalProject      = "cabal.project"+configName CabalProjectLocal = "cabal.project.local"+configName StackConfig       = "stack.yaml"+++-- Snapshot filesystem data only; root selection stays in the property model.+readAncestorEntries :: FilePath -> IO [(FilePath, DirectoryEntry)]+readAncestorEntries root = traverse readEntry parents+  where+    parents = reverse . drop 1 . scanl' (</>) "" . splitDirectories . takeDirectory $ root++    readEntry dir = do+      files <- filterM (doesFileExist . (dir </>)) =<< listDirectory dir+      let config = find ((`elem` files) . configName)+                 $ [CabalProject, CabalProjectLocal, StackConfig]+          package = any ((== ".cabal") . takeExtension) files+      pure (dir, DirectoryEntry config package)+++withTestDirectory :: (FilePath -> IO a) -> IO a+withTestDirectory action = do+    tmp <- getTemporaryDirectory+    bracket (do (path, h) <- openTempFile tmp "ghc-tags-project-test"+                hClose h+                removeFile path+                createDirectory path+                canonicalizePath path)+            removeDirectoryRecursive+            action

@@ -0,0 +1,75 @@+module Test.Timing (tests) where++import Data.IORef+import qualified Data.Map.Strict as Map+import Data.Word (Word16, Word64)+import qualified Pipes+import qualified Pipes.Prelude as Pipes+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.QuickCheck++import Plugin.GhcTags.Timing+++tests :: TestTree+tests = testGroup "Timing"+    [ testProperty "stream phases exclude upstream and downstream work" streamTimingProp+    , testProperty "lock wait excludes the action and release" lockTimingProp+    , testProperty "disabled timing preserves laziness and avoids the clock" disabledTimingProp+    ]+++streamTimingProp :: [(Word16, Word16, Word16, Word16)] -> Property+streamTimingProp steps = ioProperty $ do+    clock <- newIORef 0+    report <- newIORef Nothing+    emitted <- newIORef []+    let advance amount = modifyIORef' clock (+ fromIntegral amount)+    withTimingsUsing (readIORef clock) True (writeIORef report . Just) $ \timings -> do+      let source = timedProducer timings ReadTags $+            mapM_ (\step@(readTime, _, _, _) -> Pipes.liftIO (advance readTime) >> Pipes.yield step) steps+          parsed = timedProducer timings ParseTags $ Pipes.for source $ \step@(_, parseTime, _, _) ->+            Pipes.liftIO (advance parseTime) >> Pipes.yield step+          merged = timedProducer timings MergeTags $ Pipes.for parsed $ \step@(_, _, mergeTime, _) ->+            Pipes.liftIO (advance mergeTime) >> Pipes.yield step+      Pipes.runEffect $ Pipes.for merged $ \step@(_, _, _, writeTime) -> Pipes.liftIO $+        timed timings WriteTags (advance writeTime >> modifyIORef' emitted (step :))+    actual <- readIORef report+    values <- reverse <$> readIORef emitted+    let readTime  = sum [fromIntegral r | (r, _, _, _) <- steps]+        parseTime = sum [fromIntegral p | (_, p, _, _) <- steps]+        mergeTime = sum [fromIntegral m | (_, _, m, _) <- steps]+        writeTime = sum [fromIntegral w | (_, _, _, w) <- steps]+        expected = TimingReport (readTime + parseTime + mergeTime + writeTime) $ Map.fromList+                     [(LockWait, 0), (ReadTags, readTime), (ParseTags, parseTime),+                      (GenerateTags, 0), (MergeTags, mergeTime), (WriteTags, writeTime)]+    pure $ (actual, values) === (Just expected, steps)+++lockTimingProp :: Word16 -> Word16 -> Word16 -> Property+lockTimingProp waitTime actionTime releaseTime = ioProperty $ do+    clock <- newIORef 0+    report <- newIORef Nothing+    let advance amount = modifyIORef' clock (+ fromIntegral amount)+        withLock action = advance waitTime >> action <* advance releaseTime+    withTimingsUsing (readIORef clock) True (writeIORef report . Just) $ \timings ->+      timedLock timings withLock $ timed timings WriteTags $ advance actionTime+    actual <- readIORef report+    let expected = TimingReport (sum $ map fromIntegral [waitTime, actionTime, releaseTime]) $ Map.fromList+                     [(LockWait, fromIntegral waitTime), (ReadTags, 0), (ParseTags, 0),+                      (GenerateTags, 0), (MergeTags, 0), (WriteTags, fromIntegral actionTime)]+    pure $ actual === Just expected+++disabledTimingProp :: [Int] -> Property+disabledTimingProp values = ioProperty $ do+    calls <- newIORef (0 :: Int)+    let forbidden = error "disabled timing used the clock or reported timings"+    result <- withTimingsUsing (forbidden :: IO Word64) False (const forbidden) $ \timings ->+      timedLock timings id $ do+        (items, _) <- timedNF timings GenerateTags $ do+          modifyIORef' calls (+ 1)+          pure (values, error "disabled timing forced the result" :: Int)+        timed timings MergeTags $ Pipes.toListM $ timedProducer timings ParseTags $ Pipes.each items+    count <- readIORef calls+    pure $ (result, count) === (values, 1)

@@ -0,0 +1,21 @@+module Main (main) where++import Test.Tasty (defaultMain, testGroup)++import qualified Test.AtomicFile+import qualified Test.Check+import qualified Test.Ghc+import qualified Test.Options+import qualified Test.ProjectFile+import qualified Test.Timing+++main :: IO ()+main = defaultMain $ testGroup "ghc-tags-plugin"+    [ Test.AtomicFile.tests+    , Test.Check.tests+    , Test.Ghc.tests+    , Test.Options.tests+    , Test.ProjectFile.tests+    , Test.Timing.tests+    ]