diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -18,24 +18,102 @@ ---------------- ``` -Usage: [-e|--etags] [--stream] [--debug] [file_path] +Usage: [-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 diff --git a/app/GhcTags/Check.hs b/app/GhcTags/Check.hs new file mode 100644 --- /dev/null +++ b/app/GhcTags/Check.hs @@ -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) diff --git a/app/check.hs b/app/check.hs --- a/app/check.hs +++ b/app/check.hs @@ -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" diff --git a/ghc-tags-plugin.cabal b/ghc-tags-plugin.cabal --- a/ghc-tags-plugin.cabal +++ b/ghc-tags-plugin.cabal @@ -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 diff --git a/lib/Plugin/GhcTags.hs b/lib/Plugin/GhcTags.hs --- a/lib/Plugin/GhcTags.hs +++ b/lib/Plugin/GhcTags.hs @@ -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 diff --git a/lib/Plugin/GhcTags/AtomicFile.hs b/lib/Plugin/GhcTags/AtomicFile.hs new file mode 100644 --- /dev/null +++ b/lib/Plugin/GhcTags/AtomicFile.hs @@ -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 diff --git a/lib/Plugin/GhcTags/CTag.hs b/lib/Plugin/GhcTags/CTag.hs --- a/lib/Plugin/GhcTags/CTag.hs +++ b/lib/Plugin/GhcTags/CTag.hs @@ -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 ] + diff --git a/lib/Plugin/GhcTags/FileLock.hs b/lib/Plugin/GhcTags/FileLock.hs --- a/lib/Plugin/GhcTags/FileLock.hs +++ b/lib/Plugin/GhcTags/FileLock.hs @@ -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 diff --git a/lib/Plugin/GhcTags/Options.hs b/lib/Plugin/GhcTags/Options.hs --- a/lib/Plugin/GhcTags/Options.hs +++ b/lib/Plugin/GhcTags/Options.hs @@ -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' = diff --git a/lib/Plugin/GhcTags/Project.hs b/lib/Plugin/GhcTags/Project.hs new file mode 100644 --- /dev/null +++ b/lib/Plugin/GhcTags/Project.hs @@ -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 diff --git a/lib/Plugin/GhcTags/Timing.hs b/lib/Plugin/GhcTags/Timing.hs new file mode 100644 --- /dev/null +++ b/lib/Plugin/GhcTags/Timing.hs @@ -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" diff --git a/test/Test/AtomicFile.hs b/test/Test/AtomicFile.hs new file mode 100644 --- /dev/null +++ b/test/Test/AtomicFile.hs @@ -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"]) diff --git a/test/Test/Check.hs b/test/Test/Check.hs new file mode 100644 --- /dev/null +++ b/test/Test/Check.hs @@ -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}]) diff --git a/test/Test/Ghc.hs b/test/Test/Ghc.hs new file mode 100644 --- /dev/null +++ b/test/Test/Ghc.hs @@ -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 _ = [] diff --git a/test/Test/Ghc/Generators.hs b/test/Test/Ghc/Generators.hs new file mode 100644 --- /dev/null +++ b/test/Test/Ghc/Generators.hs @@ -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)] + ] diff --git a/test/Test/Options.hs b/test/Test/Options.hs new file mode 100644 --- /dev/null +++ b/test/Test/Options.hs @@ -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 diff --git a/test/Test/ProjectFile.hs b/test/Test/ProjectFile.hs new file mode 100644 --- /dev/null +++ b/test/Test/ProjectFile.hs @@ -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 diff --git a/test/Test/Timing.hs b/test/Test/Timing.hs new file mode 100644 --- /dev/null +++ b/test/Test/Timing.hs @@ -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) diff --git a/test/main.hs b/test/main.hs new file mode 100644 --- /dev/null +++ b/test/main.hs @@ -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 + ]