From bcc5702508c494b46c0e8f50129d1bcb5c1ce5b0 Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Wed, 29 Apr 2026 19:34:18 +0530 Subject: [PATCH 01/11] Make minor edits in README --- README.md | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/README.md b/README.md index 2c8d88a..0629211 100644 --- a/README.md +++ b/README.md @@ -43,10 +43,10 @@ https://github.com/composewell/streamly. Packdiff uses the hoogle file created by haddock to generate and compare the difference between multiple versions of a package -1. The API for modules in the `other-modules` sections is not generated or - compared. -2. The re-exported module is just considered a re-exported module. The API of - the re-exported module isn't merged with the module that re-exports it. +1. The API for modules in the `other-modules` (unexposed modules) + sections is not generated or compared. +2. The API of a re-exported module isn't merged with the module that + re-exports it. The 2nd limitation might end up falsely reporting a diff even if the diff does not exist. In our use-case where we have manual intervention this isn't a From f023dec0ced1b0e6009907c62765307cd4250d40 Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Thu, 8 Oct 2026 10:54:08 +0530 Subject: [PATCH 02/11] Update streamly-packages flake revision to match streamly --- flake.lock | 18 +++++++++--------- flake.nix | 2 +- 2 files changed, 10 insertions(+), 10 deletions(-) diff --git a/flake.lock b/flake.lock index 970b20d..114d59a 100644 --- a/flake.lock +++ b/flake.lock @@ -7,33 +7,33 @@ "nixpkgs-darwin": "nixpkgs-darwin" }, "locked": { - "lastModified": 1775312922, - "narHash": "sha256-V292VAXWHHN2Q6xKqs45BqSPego/jtEp+Pc8H/gneEU=", + "lastModified": 1776414440, + "narHash": "sha256-Be67u+Qea2sEuI+3BVjkc+o4fYgRT/fOANGNAp2OuFk=", "ref": "refs/heads/master", - "rev": "76420910d9c74e5fc1d92d680499c97e4f94e873", - "revCount": 118, + "rev": "69728978adc44f53b3dd907acb2eb5bd2415fd60", + "revCount": 125, "type": "git", "url": "ssh://git@github.com/composewell/streamly-packages" }, "original": { - "rev": "76420910d9c74e5fc1d92d680499c97e4f94e873", + "rev": "69728978adc44f53b3dd907acb2eb5bd2415fd60", "type": "git", "url": "ssh://git@github.com/composewell/streamly-packages" } }, "basepkgs_2": { "locked": { - "lastModified": 1775305167, - "narHash": "sha256-BPBKbDZ9aoGOHDAeScwj/N4h2IHOLLRSJmSC3AXQZko=", + "lastModified": 1776376172, + "narHash": "sha256-tVn1PuKG+kJGH2PUnV3weRHDnbtgUDlwwSC0K3A45aM=", "owner": "composewell", "repo": "nixpack", - "rev": "fc492c73877aeaa3bf9bec85d0eebc56036d53f9", + "rev": "f50a0b2aaaab434f46847bc171240957b508b901", "type": "github" }, "original": { "owner": "composewell", "repo": "nixpack", - "rev": "fc492c73877aeaa3bf9bec85d0eebc56036d53f9", + "rev": "f50a0b2aaaab434f46847bc171240957b508b901", "type": "github" } }, diff --git a/flake.nix b/flake.nix index 5482f54..2a08fc4 100644 --- a/flake.nix +++ b/flake.nix @@ -2,7 +2,7 @@ description = "Packdiff Development Environment"; inputs = { - basepkgs.url = "git+ssh://git@github.com/composewell/streamly-packages?rev=76420910d9c74e5fc1d92d680499c97e4f94e873"; + basepkgs.url = "git+ssh://git@github.com/composewell/streamly-packages?rev=69728978adc44f53b3dd907acb2eb5bd2415fd60"; nixpkgs.follows = "basepkgs/nixpkgs"; nixpkgs-darwin.follows = "basepkgs/nixpkgs-darwin"; }; From 1aa4d00414ba03f4546fd1a3cfda6e38e49010de Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Mon, 12 Oct 2026 16:58:09 +0530 Subject: [PATCH 03/11] Add a design doc --- dev/design.md | 920 +++++++++++++++++++++++++++++++++++++++++++++++++ packdiff.cabal | 5 +- 2 files changed, 924 insertions(+), 1 deletion(-) create mode 100644 dev/design.md diff --git a/dev/design.md b/dev/design.md new file mode 100644 index 0000000..fbd3b29 --- /dev/null +++ b/dev/design.md @@ -0,0 +1,920 @@ +# packdiff CLI Design + +> Find API changes between different versions of a Haskell package. + +--- + +## Overview + +packdiff compares two versions of a Haskell package and reports API +changes: added, removed, changed, and deprecated symbols. It works by +diffing the hoogle files generated by haddock, and only covers exposed +modules — unexposed modules in `other-modules` are excluded by design. + +--- + +## Requirements + +packdiff runs external programs, found in `PATH`. Which ones are needed +depends on the refs. This section also belongs in the user +documentation. + +| Program | Needed for | +|---------|------------| +| `git` | Git refs: `` and `git:`. Any version. | +| `cabal` (cabal-install) | Every ref except `file:`: git refs and `.` are built with it, and `hackage:` refs are resolved, downloaded and built with it. | +| `ghc` | Same as `cabal`. Selected with `-w`; otherwise the `ghc` in `PATH`. | +| `haddock` | Same as `cabal`. cabal uses the `haddock` that matches the selected `ghc`. | + +Network access is needed for: + +* `hackage:` refs: `cabal get` downloads the source of the release. + Resolving versions uses cabal's local package index, which must be + present and up to date (`cabal update`). +* Git refs of a remote repository (`--repo `): `git ls-remote` + and `git fetch`. +* Building any ref whose dependencies are not yet in the cabal store. + +`file:` refs need none of these. `diff file:a.txt file:b.txt` runs +without git, cabal, ghc or network access. + +packdiff makes no network requests itself and needs no HTTP client +library. All downloads are done by `git` and `cabal`. + +packdiff checks for the programs needed by the given refs before doing +any work. If one is missing, it prints the program name and the ref +that needs it, and exits with code 2. + +packdiff runs on Linux, macOS and Windows. + +--- + +## Commands + +There are three commands. Everything else is flags. + +| Command | Description | +|---------|-------------| +| `packdiff diff [ []]` | Print the API diff between two refs. | +| `packdiff check [ []]` | Print the version bump required by the diff. | +| `packdiff api []` | Print the API of a single ref. | + +In `diff` and `check`, `ref1` is the old version and `ref2` is the new +version. If `ref2` is omitted it defaults to `.`. If both are omitted, +`ref1` defaults to `HEAD` and `ref2` to `.`. In `api`, `ref` defaults to +`.`. + +### Refs + +A ref has the form `:`. A ref without a scope is a git +ref, except `.` and `hackage`, which are described below. + +| Ref | Meaning | +|-----|---------| +| ``, `git:` | A git commit SHA, tag or branch, e.g. `v1.2.0`, `abc1234`. It is resolved in the current repository unless `--repo`, `--old-repo` or `--new-repo` names another one. | +| `.` | The current working directory, including uncommitted changes. | +| `hackage:` | A specific published Hackage release. | +| `hackage:latest` | The latest published Hackage release. | +| `file:` | A hoogle file on disk, e.g. one written by `packdiff api`. | + +`hackage` alone is accepted as a shorthand for `hackage:latest`. A git +tag or branch named `hackage` can be given as `git:hackage`. + +### Refs of other repositories + +A git ref is a plain revision. The repository it belongs to is given by +a flag, not embedded in the ref: + +| Flag | Description | +|------|-------------| +| `--repo ` | Repository for git refs: a local path or a remote URL. With `diff` and `check` it applies to both refs. Default: the repository of the current directory. | +| `--old-repo ` | Repository for `ref1` only. Overrides `--repo` for `ref1`. | +| `--new-repo ` | Repository for `ref2` only. Overrides `--repo` for `ref2`. | + +```sh +# two tags of a remote repository, without a local clone +packdiff diff --repo https://github.com/composewell/streamly v0.9.0 v0.10.0 + +# a branch of another local repository vs HEAD of the current one +packdiff diff --old-repo ../streamly-other my-branch HEAD + +# branches of two different repositories +packdiff diff --old-repo ../repo-a --new-repo ../repo-b master master + +# API of a tag in a remote repository +packdiff api --repo https://github.com/composewell/streamly v0.10.0 +``` + +This works for clones of the same repository and for unrelated +repositories. Worktrees created with `git worktree add` share one +repository, so their branches are also plain git refs in each other. + +Only committed states of another repository can be compared. `.` +always refers to the current working directory, which is the only way +to include uncommitted changes. + +packdiff exits with code 2 if a repository flag applies only to refs +that are not git refs, e.g. `--old-repo` with a `hackage:` or `file:` +`ref1`, or `--new-repo` with `.` as `ref2`. + +### Package selection + +A repository can contain several packages, e.g. the streamly +repository contains `streamly` and `streamly-core`, both listed in its +`cabal.project`. packdiff compares the API of one package, so in such a +repository the package has to be selected. + +| Flag | Description | +|------|-------------| +| `-p / --package ` | Package to compare, for repositories with several packages. | + +A package is needed when a ref is `.`, a git ref or a Hackage ref. +`file:` refs need none. + +packdiff does not parse `cabal.project` or .cabal files. It builds the +package with `cabal haddock`, and cabal finds the package: + +* With `--package `, packdiff runs `cabal haddock ` in the + root directory of each ref, and cabal finds the package by name + through its own project discovery. The package can be in a different + directory in the two refs. +* Without `--package`, packdiff runs `cabal haddock` without a target, + and cabal builds the package in the directory it runs in. For a ref + of the current repository, that directory is the subdirectory of the + ref that corresponds to the current directory, e.g. `core/` when + packdiff is run in `core/`. For a ref of another repository, it is + the root directory of that repository. If the directory contains no + package, e.g. the root of a repository with several packages, cabal + prints an error and packdiff exits with code 3. + +The package name and version of a built ref come from the `@package` +and `@version` lines of the generated hoogle file. + +A Hackage ref needs the package name to locate the release. Without +`--package`, packdiff obtains the other ref first and takes the name +from the `@package` line of its hoogle file. When there is no other +ref to take the name from, i.e. both refs of `diff` or `check` are +Hackage refs, or the ref of `api` is a Hackage ref, `--package` is +required; without it packdiff exits with code 2. + +In a Hackage ref, the package is the source unpacked by `cabal get`. +`--cabal-option` passes options such as `--project-file=` to +cabal; they apply to every ref that is built, so a project file given +this way must exist in each of them. + +### Comparing a package with several packages + +packdiff compares one package with one package. When a package is split +into several, e.g. `streamly-0.8.3` into `streamly` and `streamly-core` +in streamly 0.9, the old package can be compared with the union of the +new ones by concatenating their hoogle files: + +```sh +packdiff api -p streamly HEAD --format hoogle > streamly.txt +packdiff api -p streamly-core HEAD --format hoogle > streamly-core.txt +cat streamly.txt streamly-core.txt > new.txt +packdiff api -p streamly hackage:0.8.3 --format hoogle > old.txt +packdiff diff file:old.txt file:new.txt +``` + +The parser reads a concatenated file as one API: `@package` and +`@version` lines are skipped and each `module` line starts a new +module. Parsing the concatenated hoogle files of `streamly-core-0.2.2` +and `streamly-0.10.1` gives the same 98 modules, with no differences, +as parsing the two files separately and merging the results with +`mergeNonConflictingAPI`. + +If the two packages have a module with the same name, the module from +the later file replaces the one from the earlier file. + +### `packdiff diff` + +Compares two refs and prints the API diff. This output also serves as +the API changelog — there is no separate log command. + +```sh +# two git tags +packdiff diff v1.2.0 v1.3.0 + +# a tag vs HEAD +packdiff diff v1.2.0 HEAD + +# HEAD vs working directory +packdiff diff HEAD +packdiff diff + +# latest published Hackage release vs HEAD +packdiff diff hackage HEAD + +# two Hackage versions +packdiff diff -p streamly hackage:1.1.0 hackage:1.2.0 + +# committed API baseline vs working directory +packdiff diff file:api/streamly.txt . + +# CI: fail if breaking changes are detected +packdiff diff hackage HEAD --fail-on breaking +``` + +### `packdiff check` + +Classifies the diff and prints the required version bump according to +the PVP. The base version is `ref1`'s version, taken from the +`@version` line of its hoogle file; this works the same way for git, +Hackage and `file:` refs. A hoogle file with more than one `@version` +line, e.g. a concatenation of several packages, cannot be used with +`check`, and packdiff exits with code 2. + +PVP versions have the form `A.B.C.D`, where `A.B` is the major version. + +| Changes in the diff | Required bump | Example from `1.2.0.0` | +|---------------------|---------------|------------------------| +| Any breaking change | `A.B` | `1.3.0.0` | +| Additions only | `C` | `1.2.1.0` | +| No API change | `D` | `1.2.0.1` | + +The breaking/non-breaking classification is defined in +[Change Classification](#change-classification). + +`check` also compares the required bump against `ref2`'s version, the +version declared in its .cabal file, taken from the `@version` line of +its hoogle file. If the declared version is lower than the required +version, `check` exits with code 1. + +```sh +packdiff check v1.2.0 HEAD + -> breaking changes detected: bump major (1.3.0.0) + -> declared version 1.2.1.0 is insufficient + +packdiff check v1.2.0 HEAD + -> new symbols added: bump minor (1.2.1.0) + -> declared version 1.2.1.0 is sufficient + +packdiff check v1.2.0 HEAD + -> no API changes detected: bump patch (1.2.0.1) +``` + +### `packdiff api` + +Prints the API of a single ref, with the released and internal modules +in separate sections. The API can also be written as a hoogle file, +which can be committed to the repository as an API baseline and used +later as a `file:` ref. + +| Flag | Description | +|------|-------------| +| `--format ` | `text` (default): the API in the same tree format as the diff output, with every entity marked `[+]`. `hoogle`: the hoogle file generated by haddock, unchanged and with all modules. | + +```sh +packdiff api -p streamly hackage:1.2.0 +packdiff api . --format hoogle > api/streamly.txt +``` + +--- + +## Output Format + +The diff is printed as a tree: each module with a change is a top-level +line, and the changed entities of the module are indented below it. +There is no legend or banner; the sigils are explained in `--help` and +in the user documentation. The output ends with a summary. + +Example (illustrative): + +``` +[D] Streamly.Data.Array.Foreign +[~] Streamly.Data.Fold + [~] data Step s b + [+] Partial :: s -> Step s b + [+] instance Monad m => Functor (Fold m a) + [~] toHashMapIO + - toHashMapIO :: (MonadIO m, Hashable k, Ord k) => (a -> k) -> Fold m a b -> Fold m a (HashMap k b) + + toHashMapIO :: (MonadIO m, Hashable k) => (a -> k) -> Fold m a b -> Fold m a (HashMap k b) + [~] <> + - infixr 6 <> + + infixr 5 <> +[+] Streamly.Data.Scanl (12 symbols) +[~] Streamly.Data.Stream.Prelude + [+] useAcquire :: AcquireIO -> Config -> Config + [D] parEval :: MonadAsync m => (Config -> Config) -> Stream m a -> Stream m a +[-] Streamly.Data.Unfold.Old (25 symbols) + +Internal modules: +[~] Streamly.Internal.Data.Fold + [+] foldtM' :: Monad m => (s -> a -> m (Step s b)) -> m (Step s b) -> (s -> m b) -> Fold m a b + +Modules: 1 added [+], 1 removed [-], 2 changed [~], 1 deprecated [D] +Symbols: 3 added [+], 3 changed [~], 1 deprecated [D] +Internal modules: 1 changed [~] +Breaking changes: 4 +``` + +### Sigils + +| Sigil | Module line | Entity line | +|-------|-------------|-------------| +| `[+]` | The module is new in `ref2`. | The entity is new in `ref2`. | +| `[-]` | The module exists in `ref1` and not in `ref2`. | The entity exists in `ref1` and not in `ref2`. | +| `[~]` | The module exists in both refs and some entity in it changed. | The entity's definition changed. | +| `[D]` | The module is deprecated in `ref2` and was not deprecated in `ref1`. | The entity is deprecated in `ref2` and was not deprecated in `ref1`. | +| `[U]` | The module is deprecated in `ref1` and not deprecated in `ref2`. | The entity is deprecated in `ref1` and not deprecated in `ref2`. | + +Below a `[~]` entity, a line starting with `-` is the definition in +`ref1` and a line starting with `+` is the definition in `ref2`. + +`+`, `-` and `~` are the usual symbols for added, removed and changed, +e.g. in `diff` and in Terraform plans. A removed entity is shown by its +`ref1` definition and an added one by its `ref2` definition, the same +as the `-` and `+` lines. Deprecation is a change of status, not of +structure, so it keeps a letter; with removal written as `[-]`, `[D]` +cannot be read as "deleted". + +### Entities + +| Entity | Line | +|--------|------| +| Function, class method, pattern synonym | The signature, e.g. `useAcquire :: AcquireIO -> Config -> Config`. | +| Data type, newtype | The declaration head, e.g. `data Step s b`, with changed constructors and fields indented below it. | +| Type synonym | The declaration, e.g. `type Config = ...`. | +| Class | The declaration head, e.g. `class Monad m => MonadAsync m`. | +| Instance | The instance head, e.g. `instance Monad m => Functor (Fold m a)`. | +| Fixity | In source syntax, e.g. `infixr 5 <>`. | + +A `[~]` line names the entity: the name for a function or fixity, the +declaration head for a data type, newtype or class. The `-` and `+` +lines below it give the full old and new definitions. For a data type +or newtype whose head is unchanged, the lines below it are the changed +constructors and fields, each with its own sigil. + +### What each module line shows + +| Module | Shown | +|--------|-------| +| Added | The module line only, with the number of entities in it: `[+] Streamly.Data.Scanl (12 symbols)`. | +| Removed | The module line only, with the number of entities it had: `[-] Streamly.Data.Unfold.Old (25 symbols)`. | +| Deprecated or undeprecated | The module line. Changed entities, if any, are listed below it as for a changed module. | +| Changed | The module line and the changed entities. | + +The entities of an added or removed module are not listed, so that a +large new module does not fill the diff. `packdiff api --module +` prints them: with `ref2` for an added module, with `ref1` for a +removed one. + +### Order + +Modules are sorted by name, in ascending order. Within a module, +entities are grouped by kind in this order: data types and newtypes, +type synonyms, classes, instances, pattern synonyms, functions, +fixities. Within a group they are sorted by name. Constructors and +fields keep their order in the hoogle file. + +### Internal modules + +Modules matching `--internal-module` are printed after the other +modules, under the line `Internal modules:`, in the same format. + +### Summary + +The output ends with a blank line followed by the summary, one line per +kind of count: + +| Line | Counts | +|------|--------| +| `Modules:` | Modules, by sigil. | +| `Symbols:` | Entity lines of changed modules, by sigil. | +| `Internal modules:` | Internal modules, by sigil. | +| `Breaking changes:` | Module and entity changes classified as breaking (see [Change Classification](#change-classification)). | + +Each count is followed by its sigil, so the summary also explains the +sigils used in the output. Counts that are zero are omitted, and a line +whose counts are all zero is omitted. An empty diff prints +`No API changes.` + +`-q` prints only the summary. `--modules-only` prints the module lines +and the summary. + +### Grouping by change + +With `--group-by change`, the output has one section per sigil, in the +order removed, changed, deprecated, undeprecated, added. Each section +starts with a line naming it, e.g. `Removed:`. Entity lines in these +sections are qualified with their module name, e.g. +`[-] Streamly.Data.Fold.foo :: ...`. + +### Color + +With color enabled, `[-]` and `-` lines are red, `[+]` and `+` lines +are green, `[~]` lines are yellow, and `[D]` and `[U]` lines are +magenta. In a pair of `-` and `+` lines, the parts that differ are +highlighted, so a changed constraint in a long signature stands out. + +### Line structure + +Scripts can rely on the following: + +* Each entity is on one line; lines are never wrapped. +* Each nesting level is indented by 4 spaces. +* After its indentation, every line except a section heading and the + summary starts with a sigil (`[+]`, `[-]`, `[~]`, `[D]`, `[U]`), `-` + or `+`. +* The summary lines come last; each starts with `Modules:`, + `Symbols:`, `Internal modules:` or `Breaking changes:`. + +For example, `grep '^ *\[-\]'` lists every removal; the pattern is +anchored to the start of the line because the summary lines also +contain sigils. An entity line does not contain its module name in the +default grouping, so attributing a line to its module requires the +preceding module line. + +--- + +## Change Classification + +A change is either breaking or non-breaking. This follows the PVP +rules for a major version bump. + +| Change | Breaking | +|--------|----------| +| Symbol, type, class or module removed | yes | +| Symbol removed that was deprecated in `ref1` | yes | +| Type signature changed | yes | +| Data type definition changed, including an added constructor or field | yes | +| Class definition changed, including an added method | yes | +| Instance removed | yes | +| Fixity changed | yes | +| Symbol, type, class, instance or module added | no | +| Symbol or module deprecated | no | +| Symbol or module undeprecated | no | + +packdiff compares definitions textually and cannot decide whether a +changed signature is source-compatible. Every changed signature is +classified as breaking. For example, removing the `Ord k` constraint +from `toHashMapIO` above is compatible for callers but is still +reported as `[~]` and classified as breaking. + +An added orphan instance is breaking under the PVP. The hoogle file +does not mark instances as orphans, so added instances are classified +as non-breaking. + +--- + +## Flags + +The flags for refs (`--repo`, `--old-repo`, `--new-repo`) and packages +(`--package`) are described in the sections above. + +### Output and formatting + +| Flag | Description | +|------|-------------| +| `--color ` | Color control: `auto` (default), `always`, `never`. `auto` disables color when `NO_COLOR` is set or stdout is not a terminal. | +| `--group-by ` | `module` (default): changes grouped by module. `change`: one section per change kind, for use in a changelog. See [Grouping by change](#grouping-by-change). | +| `-q / --quiet` | Print only the summary. | +| `--modules-only` | Print only the module lines and the summary. | + +### Filtering + +| Flag | Description | +|------|-------------| +| `--show ` | Show only these change types. Values: `added`, `removed`, `changed`, `deprecated`, `undeprecated`. Mutually exclusive with `--hide`. | +| `--hide ` | Hide these change types. Mutually exclusive with `--show`. | +| `--breaking-only` | Shorthand for `--show removed,changed`. | +| `--module ` | Narrow the output of `diff` or `api` to modules matching the glob. Repeatable. | +| `--ignore-module ` | Exclude modules matching the glob. Repeatable. Used to suppress known re-export false positives. | +| `--internal-module ` | Treat matching modules as internal. Repeatable. Default: `*.Internal.*` and `*.Internal`. | + +`` is a comma-separated list, and the flag may also be repeated: +`--show added,removed` is the same as `--show added --show removed`. + +### CI and exit codes + +| Flag | Description | +|------|-------------| +| `--fail-on ` | `diff` only. Exit 1 if the diff contains any change of these types. Takes the same values as `--show`, plus `breaking` (removed and changed) and `any`. | + +Filters apply in this order: + +1. `--module` and `--ignore-module` select the modules that are + diffed. `--internal-module` marks modules as internal; internal + modules are diffed and printed in their own section, but never count + towards `--fail-on`. +2. `--fail-on` is evaluated on the result. +3. `--show`, `--hide`, `--breaking-only`, `-q` and `--modules-only` + affect only what is printed. They do not change the exit code. + +Exit codes: + +| Code | Meaning | +|------|---------| +| `0` | Success. For `diff` with `--fail-on`: no change reached the threshold. For `check`: the declared version is sufficient. `diff` without `--fail-on` and `api` always exit with 0 on success. | +| `1` | The `--fail-on` threshold was reached, or `check` found the declared version insufficient. | +| `2` | Usage error, including a missing external program. | +| `3` | Failure to obtain an API: a failed `git` or `cabal` command (including their downloads), a build or haddock failure, or a hoogle file parse error. | + +Haskell programs exit with 1 on an uncaught exception, so all +exceptions must be caught at the top level and mapped to 2 or 3. + +### Build options + +| Flag | Description | +|------|-------------| +| `-w / --with-compiler ` | Compiler used to build each ref. | +| `--cabal-option ` | Extra option passed to `cabal haddock` for every ref that is built, e.g. `--project-file=cabal.project.ci`. Repeatable. | +| `--no-cache` | Do not read or write the hoogle file cache. | +| `--work-dir ` | Directory for work clones, unpacked Hackage sources, and their build directories. Default: `$XDG_CACHE_HOME/packdiff/work`. | +| `--in-place` | Build git refs of the current repository by checking them out in the current working tree. See [In-place mode](#in-place-mode). | + +--- + +## Implementation + +### Pipeline + +1. **Resolve** each ref to a source: a git revision, the working + directory, a Hackage release, or a hoogle file. +2. **Obtain** the hoogle file of the package in each ref. +3. **Parse** each hoogle file into an API (`HoogleFileParser`). +4. **Diff** the two APIs (`Diff`). +5. **Classify** each change as breaking or non-breaking. +6. **Filter** modules and evaluate `--fail-on`. +7. **Render** in the selected format (`Pretty`). + +### Obtaining a hoogle file + +packdiff first resolves a git ref to a commit SHA, or a Hackage ref to +a version, and looks the hoogle file up in the cache. The methods below +run only when the cache has no entry. + +| Source | Method | +|--------|--------| +| git revision, local repository | Check out the revision in a work clone made with `git clone --shared`, then run `cabal haddock --haddock-hoogle` with the work clone's build directory. | +| git revision, remote repository | `git fetch --depth 1 ` into a work clone and build as above. The SHA comes from `git ls-remote`. | +| `.` | `cabal haddock --haddock-hoogle` in the working directory. | +| Hackage | Resolve the version from cabal's local package index: `cabal list --simple-output ` prints one ` ` line per version, and `hackage:latest` is the highest. Then `cabal get -` into `/--` and build it with `cabal haddock --haddock-hoogle`, with the same compiler as the other ref. If the version is not in the index, packdiff suggests running `cabal update` and exits with code 3. | +| `file:` | Read the file. | + +Unless `--in-place` is given, packdiff never runs `git checkout` in the +user's working tree, so uncommitted changes are never touched and `.` +can be diffed against any revision. + +### Work clones + +Git refs are built in work clones under the work directory +(`--work-dir`, default `$XDG_CACHE_HOME/packdiff/work`). Each run +creates one work clone per source repository, at +`/-`, where `` is a hash of the repository's +absolute path or URL. Each work clone contains: + +* `src/`: the clone, with the revision being built checked out. +* `build/`: the cabal `--builddir`. + +When both refs of a `diff` come from the same repository, they are +built one after the other in the same work clone, so the second build +recompiles only the modules that differ between the two revisions. The +dependencies come from the cabal store. + +Work clones and unpacked Hackage sources are deleted when the run +ends, including on an exception, `SIGINT`, `SIGTERM` or `SIGHUP`. A +directory left behind by a killed run is deleted by the next run, +which detects it by its process id no longer running (`kill` with +signal 0 on POSIX systems, `OpenProcess` on Windows). + +Work clones are not kept across runs because their build directory is +large and packdiff is run infrequently. For streamly, the haddock build +directory is about 160 MB. Repeated runs on the same revision are +served from the hoogle file cache instead, which holds about 1 MB per +package version (`streamly-core-0.2.2` is 770 KB). + +The work directory is on disk under the XDG cache directory, not in +`/tmp`, because `/tmp` is often a RAM-backed tmpfs and the build +directory can be hundreds of MB. `$XDG_CACHE_HOME` stands for the +directory returned by `getXdgDirectory XdgCache` from the `directory` +package: `~/.cache` by default on Linux and macOS, `%LOCALAPPDATA%` on +Windows. + +Hackage releases are not cloned; `cabal get` unpacks them into +`/--`, which is handled the same way as a work +clone. + +**Local repositories.** The work clone is created with +`git clone --shared --no-checkout src`. `--shared` copies no +objects: the clone records the source repository's object directory in +`.git/objects/info/alternates` and reads objects from there. It works +across filesystems, because the alternates file holds a path, not hard +links. (Without `--shared`, a local clone hard-links the object files +and copies them when the source is on another filesystem.) A revision is +resolved to a SHA in the source repository and checked out with +`git -C src checkout --detach `; no fetch is needed because the +objects are visible through the alternates file. + +A `--shared` clone breaks if the source repository deletes objects that +the clone still references, e.g. when a branch is deleted and +`git gc` runs. A work clone exists only for the duration of one run and +checks out revisions that are reachable in the source repository, so +this does not happen in practice. + +**Remote repositories.** `--shared` applies only to local +repositories. For a remote URL the work clone is created with +`git init`, and each revision is fetched with +`git fetch --depth 1 `, which downloads only the files of +that commit. The revision is first resolved to a SHA with +`git ls-remote`, so a cached hoogle file for that SHA is used without +any download. `git ls-remote` lists only branches and tags, so a +revision of a remote repository must be a branch, a tag or a full +commit SHA; expressions such as `v1.0~2` or an abbreviated SHA are +rejected with exit code 2. Fetching a commit by SHA requires the +server to allow it; GitHub does. + +`git clone --shared`, `git fetch --depth` and `git ls-remote` are +available in all Git versions packdiff will meet; there is no minimum +Git version. + +### In-place mode + +With `--in-place`, git refs of the current repository are checked out +in the current working tree and built in the default `dist-newstyle`. +This reuses the existing build of the working tree and needs no work +clone, so it is the fastest mode when `dist-newstyle` is already built. + +* packdiff exits with code 2 if tracked files have uncommitted changes. + Untracked files are left in place and are part of every build. +* packdiff prints the current branch (or the SHA, if `HEAD` is + detached) before the first checkout, and checks it out again when the + run ends, including on an exception, `SIGINT` (Ctrl-C), `SIGTERM` or + `SIGHUP`. If packdiff is killed with `SIGKILL`, the tree stays on the + last revision built, and the printed branch tells the user what to + check out. +* The restore uses a plain `git checkout`, never `--force`. If it + fails, e.g. because a build modified a tracked file, packdiff prints + the original branch and the git error and exits with code 3. +* `.` is the same as `HEAD`, because the tree has no uncommitted + changes. +* Refs of other repositories (`--repo`, `--old-repo`, `--new-repo`) + still use work clones. + +### Cleanup on interruption + +Cleanup means restoring the original branch in in-place mode and +deleting the work clones otherwise. It runs on normal exit, on an +exception and on the signals below. + +* `SIGINT`: the GHC runtime delivers the first `SIGINT` as a + `UserInterrupt` exception to the main thread. The checkouts and + builds run inside `bracket`/`finally`, so the cleanup runs. +* `SIGTERM` and `SIGHUP`: the GHC runtime does not turn these into + exceptions; by default the process exits without running any + cleanup. CI cancellations send `SIGTERM` and closing the terminal + sends `SIGHUP`. packdiff installs handlers for both that throw an + exception to the main thread. +* The cleanup runs under `uninterruptibleMask_`, so a second Ctrl-C + during the cleanup does not abort it halfway. +* Ctrl-C sends `SIGINT` to the whole process group, so a running `git` + or `cabal` also receives it. packdiff waits for the child process to + exit before cleaning up. Otherwise the restore can fail on a + `.git/index.lock` that an interrupted `git checkout` has not yet + removed. +* On Windows there are no `SIGTERM` or `SIGHUP` signals. The GHC + runtime delivers Ctrl-C as `UserInterrupt` as on POSIX systems. + packdiff installs a console handler (`GHC.ConsoleHandler`) that + throws an exception to the main thread on Ctrl-Break and on closing + the console window, which correspond to `SIGTERM` and `SIGHUP`. + +### Effect on the user's repository + +Without `--in-place`, packdiff writes nothing inside the user's +repository, including `.git`. It does not modify tracked files, +uncommitted changes, the index, `HEAD`, branches, tags or remotes. It +writes only the following: + +| Location | What is written | When | +|----------|-----------------|------| +| `dist-newstyle/` | Haddock output for `.`, the same as running `cabal haddock` by hand. | When `.` is a ref. | +| Work directory | Work clones, unpacked Hackage sources, and their build directories. | When a ref is a git or Hackage ref. Deleted when the run ends. | +| `$XDG_CACHE_HOME/packdiff/hoogle` | Cached hoogle files. | Unless `--no-cache` is given. | + +With `--in-place`, packdiff also changes `HEAD` and the tracked files +during the run, restores the original branch at the end, and writes +the haddock output of every ref to `dist-newstyle/`. + +### Cache + +Hoogle files are cached in `$XDG_CACHE_HOME/packdiff/hoogle`, keyed by +(package name, or the subdirectory when `--package` is not given; +commit SHA or Hackage version; GHC version; haddock version; hash of +the `--cabal-option` values). The cabal options are part of the key +because cabal flags can change the API through CPP. The `.` ref is not +cached. + +The dependency build plan is not part of the key. A different +`cabal.project.local`, freeze file or package index can change the +output, e.g. the instances or re-exported entities that come from a +dependency, and a cached file then no longer matches a fresh build. +`--no-cache` forces a rebuild. + +Entries are about 1 MB each and are never evicted. Deleting +`$XDG_CACHE_HOME/packdiff/hoogle` clears the cache. The cache is kept +separate from the work directory, `$XDG_CACHE_HOME/packdiff/work`, so +clearing it cannot remove the work clones of a running packdiff. + +Entries are written to a temporary file and renamed into place, so +concurrent runs never read a partly written entry. + +### Testing + +Golden tests run the parse, diff, classify and render stages on pairs +of small hoogle files checked into the test suite. These tests need no +cabal builds or network access. + +One golden test parses the concatenation of two hoogle files and checks +that the result equals the two files parsed separately and merged with +`mergeNonConflictingAPI`. The +[concatenation recipe](#comparing-a-package-with-several-packages) +depends on this, so a parser change that breaks it fails the test. + +### Dependencies + +Haskell libraries: + +All of the non-test dependencies below are `streamly-coreutils`, +`optparse-applicative`, or their dependencies, so these two packages +determine the dependency footprint of packdiff. + +| Library | Used for | +|---------|----------| +| `base` | Exceptions and cleanup (`bracket`, `uninterruptibleMask_`), environment variables, versions (`Data.Version`), the Windows console handler (`GHC.ConsoleHandler`). | +| `containers` | The API maps. | +| `streamly-core` | Reading and parsing hoogle files, paths. | +| `streamly-process` | Running `git` and `cabal`. | +| `streamly-coreutils` | File system operations: creating and deleting directories, renaming files, finding programs in `PATH` (`Which`). | +| `directory` | `getXdgDirectory`. A dependency of `streamly-coreutils` already. | +| `optparse-applicative` | Command-line parsing and `--help`. | +| `ansi-terminal` | Colors, including enabling ANSI escape codes in the Windows console. A dependency of `optparse-applicative` (through `prettyprinter-ansi-terminal`) already. | +| `unix` (POSIX), `Win32` (Windows) | Signal handlers and checking whether a process is alive. Dependencies of `streamly-coreutils` already. | +| `hspec` | Tests only. | + +The following are written in packdiff instead of adding a library: + +* A stable hash for cache keys and work clone names, e.g. 64-bit + FNV-1a. `hashable` is not used because its output may change between + versions, which would invalidate names on disk. +* Glob matching for `--module`, `--ignore-module` and + `--internal-module`, supporting only `*`. +* Highlighting the differing parts of `-` and `+` lines: drop the + common token prefix and suffix using streamly-core's + `dropCommonPrefixBy` and highlight the rest. + +`streamly-process` already depends on the full `streamly` package, so +`streamly-coreutils` adds little: `exceptions`, `time`, `directory`, +`filepath`, `unix-compat` and `unix`/`Win32`, all GHC boot libraries +except `unix-compat`. Both bound `streamly` to `< 0.12`. + +`streamly-coreutils` is not on Hackage yet. It is to be uploaded to +Hackage before packdiff, since a package on Hackage cannot depend on +one that is not. + +--- + +## Known Limitations + +packdiff uses the hoogle file produced by haddock. Three limitations +follow from this. + +### 1. Unexposed modules are excluded + +Modules listed in `other-modules` in the .cabal file are never generated +or compared. packdiff only covers the public API surface. + +### 2. Re-exported symbols may appear as false removals + +When a module re-exports symbols from another module, packdiff cannot +merge the two and may report a removal that does not exist. In practice +this is manageable with human review in the loop. + +Mitigation: use `--ignore-module ` to suppress known +false-positive modules from CI output. + +A possible fix is to read haddock's `.haddock` interface files +(`haddock --show-interface`) instead of the hoogle file. Interface +files record the export list of each module, which allows re-exports to +be resolved. + +### 3. Different GHC or haddock versions render signatures differently + +Hoogle files generated by different GHC or haddock versions differ +textually for the same API: `forall` placement, `Type` vs `*`, operator +sections and instance ordering. A diff between such files reports +false `[~]` entries. This affects `file:` refs written with a +different compiler, and would affect hoogle files downloaded from +Hackage (see Future Work). + +Mitigation: packdiff builds every ref, Hackage releases included, +with the same compiler (`-w`). A possible further mitigation is to +normalise signatures before comparing them. + +--- + +## Future Work + +Each entry ends with the new dependencies it needs, if any. + +* `installed:` refs: diff a package installed in the current + GHC environment. The hoogle file is found through `ghc-pkg`, and + exists only if the package was installed with its documentation. + Dependencies: no new library; the `ghc-pkg` program, which ships + with GHC. +* Show the documentation of a single entity, `package:module:name`. + The parser already keeps the documentation of each entity. + Dependencies: none. +* `--old-cabal-option` and `--new-cabal-option`: cabal options for + `ref1` or `ref2` only, in addition to `--cabal-option`, in the same + way as `--old-repo` and `--new-repo` refine `--repo`. Uses: + * An old revision or Hackage release often builds with the current + GHC only with `--allow-newer` or a `--constraint`. Given with + `--cabal-option`, the option also applies to the new ref and can + change its build plan. + * With `--old-repo` and `--new-repo`, the two repositories can need + different project files or flags. + * A project file can exist in only one of the refs. + + The cache key then hashes the effective options of each ref: + `--cabal-option` plus that ref's own options. + + Without these flags, each side can be built separately and the + hoogle files diffed: + + ```sh + packdiff api -p streamly v0.8.0 --format hoogle --cabal-option=--allow-newer > old.txt + packdiff api -p streamly HEAD --format hoogle > new.txt + packdiff diff file:old.txt file:new.txt + ``` + + Dependencies: none. +* Download Hackage hoogle files instead of building releases locally. + Hackage serves the hoogle file of each release whose docs built at + `https://hackage.haskell.org/package/-/docs/.txt` + (e.g. 770 KB for `streamly-core-0.2.2`). Downloading skips the + build, but the file is rendered by Hackage's GHC and haddock + versions, which can produce false `[~]` entries against a locally + built ref (Known Limitation 3). It would be opt-in, with a flag such + as `--hackage-download`, and would shell out to `curl`, as + cabal-install itself does, instead of adding an HTTP client library. + `curl` would then be required only when the flag is given. + Dependencies: no new library; the `curl` program. +* Semver rules for `check`, as an alternative to the PVP, if a user + asks for them. Under semver a breaking change bumps `X` in `X.Y.Z`, + while the PVP accepts a bump of `B` in `A.B.C.D`, so applying PVP + rules to a package that follows semver accepts `1.2.0 → 1.3.0` for a + breaking change where semver requires `2.0.0`. Semver versions are + valid PVP versions, and cabal and Hackage read every version as a + PVP version, so PVP-based advice is never unsafe for dependents; + semver needs separate rules for `0.x` versions. Dependencies: none. +* A configuration file, e.g. `packdiff.yaml` in the repository root, + holding defaults for flags such as `--package`, `--ignore-module`, + `--internal-module`, `--fail-on` and `--cabal-option`, so that local + and CI runs use the same settings. It is not provided because there + are few flags; a YAML file needs a dependency (`yaml`, which pulls in + the C `libyaml` and `aeson`, or `HsYAML`); and it needs rules for + which repository's file applies and how command-line lists combine + with file lists. A wrapper script in the repository, called by both + CI and developers, gives the same settings today. If the list of + `--ignore-module` globs becomes long, a narrower option is + `--ignore-module-file `, reading one glob per line. + Dependencies: `yaml` or `HsYAML` for a YAML file; + `--ignore-module-file` needs none. +* An opt-in flag, e.g. `--deprecation-messages`, to print the + deprecation message below each `[D]` line. The message is in the + hoogle file, e.g. `Deprecated: SVar is replaced by Channel.`; + the haddock markup would be removed and wrapped lines joined. It is + not printed by default because GHC already shows it to every user of + the deprecated entity, messages can be long, and it adds a kind of + line to the line structure that scripts rely on. Dependencies: none. +* A line-oriented output format for scripts, one change per line with + tab-separated fields, e.g. `RStreamly.Data.Foldfoo :: ...`. + In the tree format, an entity line does not contain its module name. + Dependencies: none. +* More output formats, if a use appears. A `--format` flag for `diff` + would be added with the first of them: + * `markdown`: for PR comments and changelog entries. The `text` + output in a code fence already renders well in a PR comment. + Dependencies: none. + * `json`: for other tools to consume. It needs either `aeson`, which + brings a large dependency tree (`attoparsec`, `scientific`, + `vector`, `unordered-containers`, `hashable` and more), or + hand-written encoding of the output, which is nested lists of + strings. The schema would need a `version` field and would be a + compatibility commitment. Dependencies: `aeson`, or none with + hand-written encoding. + * `github`: GitHub Actions annotations (`::error` / `::warning` lines + on stdout), which GitHub shows in the workflow run summary. + Hoogle files have no source locations, so the annotations cannot + be attached to a file or line in the PR diff; the exit code and + the `text` output in the log give nearly the same information. + Dependencies: none. + +### Out of scope + +* Reverse dependencies: list the packages that depend on a package, + the versions they use, and their maintainers, and draft migration + notes. This needs a separate data source (the Hackage reverse + dependency index) and belongs in a separate tool. Emails, if any, + should be generated as drafts, not sent. diff --git a/packdiff.cabal b/packdiff.cabal index 16c0ec2..e040fc5 100644 --- a/packdiff.cabal +++ b/packdiff.cabal @@ -34,7 +34,10 @@ tested-with: , GHC==9.10.3 , GHC==9.8.4 , GHC==9.6.3 -extra-doc-files: README.md, CHANGELOG.md +extra-doc-files: + README.md + , CHANGELOG.md + , dev/design.md source-repository head type: git From f9f2a9ec952c947d2f93d56f186b6d5ab2f0c058 Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Mon, 12 Oct 2026 18:22:24 +0530 Subject: [PATCH 04/11] Rewrite packdiff with a new CLI and modular library Split the code into PackDiff.* library modules and add the diff, check and api commands. Refs can be git revisions (including other local or remote repositories), the working directory, Hackage releases or hoogle files. Git refs are built in temporary work clones, hoogle files are cached, and the output uses sigils, a summary, colors, filtering and grouping by change. check reports the required PVP bump, and exit codes support CI use. Add golden tests, a cabal.project with a GHC heap limit, and dev/upstream-fixes.md listing workarounds for missing upstream features. --- CHANGELOG.md | 15 + README.md | 140 +++++-- cabal.project | 14 + cabal.project.Werror | 2 +- cli/Main.hs | 338 +---------------- dev/upstream-fixes.md | 62 ++++ packdiff.cabal | 63 +++- src/Diff.hs | 180 --------- src/HoogleFileParser.hs | 523 --------------------------- src/PackDiff/API.hs | 115 ++++++ src/PackDiff/Cabal.hs | 199 ++++++++++ src/PackDiff/Cache.hs | 78 ++++ src/PackDiff/Classify.hs | 129 +++++++ src/PackDiff/Diff.hs | 170 +++++++++ src/PackDiff/Error.hs | 49 +++ src/PackDiff/Filter.hs | 146 ++++++++ src/PackDiff/Git.hs | 145 ++++++++ src/PackDiff/Hash.hs | 42 +++ src/PackDiff/HoogleFileParser.hs | 359 ++++++++++++++++++ src/PackDiff/Main.hs | 353 ++++++++++++++++++ src/PackDiff/Obtain.hs | 379 +++++++++++++++++++ src/PackDiff/Options.hs | 375 +++++++++++++++++++ src/PackDiff/Pretty.hs | 455 +++++++++++++++++++++++ src/PackDiff/Process.hs | 109 ++++++ src/PackDiff/Ref.hs | 108 ++++++ src/PackDiff/Signals.hs | 63 ++++ src/PackDiff/WorkDir.hs | 173 +++++++++ src/Pretty.hs | 207 ----------- test/Main.hs | 367 +++++++++++++++++++ test/data/new.txt | 69 ++++ test/data/old.txt | 63 ++++ test/data/pkga.txt | 13 + test/data/pkgb.txt | 10 + test/golden/api.out | 37 ++ test/golden/diff-group-by-change.out | 41 +++ test/golden/diff-modules-only.out | 13 + test/golden/diff-quiet.out | 4 + test/golden/diff-show-added.out | 18 + test/golden/diff.out | 34 ++ 39 files changed, 4363 insertions(+), 1297 deletions(-) create mode 100644 cabal.project create mode 100644 dev/upstream-fixes.md delete mode 100644 src/Diff.hs delete mode 100644 src/HoogleFileParser.hs create mode 100644 src/PackDiff/API.hs create mode 100644 src/PackDiff/Cabal.hs create mode 100644 src/PackDiff/Cache.hs create mode 100644 src/PackDiff/Classify.hs create mode 100644 src/PackDiff/Diff.hs create mode 100644 src/PackDiff/Error.hs create mode 100644 src/PackDiff/Filter.hs create mode 100644 src/PackDiff/Git.hs create mode 100644 src/PackDiff/Hash.hs create mode 100644 src/PackDiff/HoogleFileParser.hs create mode 100644 src/PackDiff/Main.hs create mode 100644 src/PackDiff/Obtain.hs create mode 100644 src/PackDiff/Options.hs create mode 100644 src/PackDiff/Pretty.hs create mode 100644 src/PackDiff/Process.hs create mode 100644 src/PackDiff/Ref.hs create mode 100644 src/PackDiff/Signals.hs create mode 100644 src/PackDiff/WorkDir.hs delete mode 100644 src/Pretty.hs create mode 100644 test/Main.hs create mode 100644 test/data/new.txt create mode 100644 test/data/old.txt create mode 100644 test/data/pkga.txt create mode 100644 test/data/pkgb.txt create mode 100644 test/golden/api.out create mode 100644 test/golden/diff-group-by-change.out create mode 100644 test/golden/diff-modules-only.out create mode 100644 test/golden/diff-quiet.out create mode 100644 test/golden/diff-show-added.out create mode 100644 test/golden/diff.out diff --git a/CHANGELOG.md b/CHANGELOG.md index 43831b6..1c4e81d 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,20 @@ # Revision history for packdiff +## Unreleased + +* New command line interface with three commands: `diff`, `check` and + `api`. +* Refs: git revisions, the working directory, Hackage releases and hoogle + files. Git refs can be of another local or remote repository. +* Git refs are built in temporary work clones instead of checking them out + in the working tree. `--in-place` checks them out in the working tree. +* Hoogle files are cached. +* New output format with `[+]`, `[-]`, `[~]`, `[D]` and `[U]` sigils, a + summary, colors, filtering and grouping by change. +* `check` prints the PVP version bump required by the diff. +* Exit codes for CI: `--fail-on`, and distinct codes for usage errors and + build failures. + ## 0.1.0.0 -- YYYY-mm-dd * First version. Released on an unsuspecting world. diff --git a/README.md b/README.md index 0629211..adfa135 100644 --- a/README.md +++ b/README.md @@ -1,53 +1,119 @@ # packdiff -**Usage:** +packdiff compares two versions of a Haskell package and reports the API +changes: added, removed, changed and deprecated symbols. It builds the +hoogle file of each version with `cabal haddock` and compares the two +files. Only exposed modules are compared. +## Usage + +``` +packdiff diff [REF1 [REF2]] # API diff between two refs +packdiff check [REF1 [REF2]] # PVP version bump required by the diff +packdiff api [REF] # API of one ref ``` -packdiff diff + +In `diff` and `check`, `REF1` is the old version and `REF2` the new one. +`REF2` defaults to `.`; with no refs, `REF1` is `HEAD` and `REF2` is `.`. +The ref of `api` defaults to `.`. + +| Ref | Meaning | +|-----|---------| +| ``, `git:` | A git commit, tag or branch. | +| `.` | The working directory, including uncommitted changes. | +| `hackage:` | A published Hackage release. | +| `hackage`, `hackage:latest` | The latest Hackage release. | +| `file:` | A hoogle file, e.g. one written by `packdiff api --format hoogle`. | + +Examples: + +```sh +packdiff diff v1.2.0 HEAD +packdiff diff # HEAD vs the working directory +packdiff diff hackage HEAD --fail-on breaking +packdiff diff -p streamly hackage:0.9.0 hackage:0.10.0 +packdiff diff --repo https://github.com/composewell/streamly v0.9.0 v0.10.0 +packdiff check v1.2.0 HEAD +packdiff api . --format hoogle > api/streamly.txt +packdiff diff file:api/streamly.txt . ``` -## API Diff Output +In a repository with several packages, select the package with +`-p/--package`. `packdiff --help` and `packdiff --help` list all +options. + +## Output ``` ---------------------------------- -API Annotations ---------------------------------- - -[A] : Added -[R] : Removed -[C] : Changed -[O] : Old definition -[N] : New definition -[D] : Deprecated - ---------------------------------- -API diff ---------------------------------- - -[C] Streamly.Data.Stream.Prelude - [A] useAcquire :: AcquireIO -> Config -> Config +[~] Streamly.Data.Fold + [~] data Step s b + [+] Partial :: s -> Step s b + [~] toHashMapIO + - toHashMapIO :: (MonadIO m, Hashable k, Ord k) => (a -> k) -> Fold m a b -> Fold m a (HashMap k b) + + toHashMapIO :: (MonadIO m, Hashable k) => (a -> k) -> Fold m a b -> Fold m a (HashMap k b) +[+] Streamly.Data.Scanl (12 symbols) +[~] Streamly.Data.Stream.Prelude + [+] useAcquire :: AcquireIO -> Config -> Config [D] parEval :: MonadAsync m => (Config -> Config) -> Stream m a -> Stream m a -[C] Streamly.Data.Fold.Prelude - [C] toHashMapIO - [O] toHashMapIO :: (MonadIO m, Hashable k, Ord k) => (a -> k) -> Fold m a b -> Fold m a (HashMap k b) - [N] toHashMapIO :: (MonadIO m, Hashable k) => (a -> k) -> Fold m a b -> Fold m a (HashMap k b) + +Modules: 1 added [+], 2 changed [~] +Symbols: 2 added [+], 2 changed [~], 1 deprecated [D] +Breaking changes: 2 ``` -## CI Integration +| Sigil | Meaning | +|-------|---------| +| `[+]` | Added in `REF2`. | +| `[-]` | Present in `REF1`, removed in `REF2`. | +| `[~]` | Definition changed. The `-` line is the `REF1` definition, the `+` line the `REF2` definition. | +| `[D]` | Deprecated in `REF2`, not deprecated in `REF1`. | +| `[U]` | Deprecated in `REF1`, not deprecated in `REF2`. | -For CI integration check out packdiff github CI in the streamly repo: -https://github.com/composewell/streamly. +Modules matching `--internal-module` (default `*.Internal.*` and +`*.Internal`) are listed separately under `Internal modules:` and do not +count towards `--fail-on`, `check` or the breaking change count. -## Limitations +## Exit codes + +| Code | Meaning | +|------|---------| +| 0 | Success. | +| 1 | The `--fail-on` threshold was reached, or `check` found the declared version insufficient. | +| 2 | Usage error, including a missing external program. | +| 3 | Failure to obtain an API: a failed `git` or `cabal` command, a build failure or a hoogle file parse error. | + +## Requirements + +packdiff runs the following programs, found in `PATH`: -Packdiff uses the hoogle file created by haddock to generate and compare the -difference between multiple versions of a package +| Program | Needed for | +|---------|------------| +| `git` | Git refs. | +| `cabal` | Every ref except `file:`. | +| `ghc` | Every ref except `file:`. Selected with `-w`. | +| `haddock` | Every ref except `file:`. | + +Network access is needed for `hackage:` refs (`cabal get`), for git refs +of a remote repository, and for building a ref whose dependencies are not +in the cabal store. Hackage versions are resolved from cabal's local +package index; run `cabal update` if a recent release is not found. + +Git refs are built in temporary clones under +`$XDG_CACHE_HOME/packdiff/work`, so the working tree is never touched +unless `--in-place` is given. Hoogle files of git and Hackage refs are +cached in `$XDG_CACHE_HOME/packdiff/hoogle`; `--no-cache` disables the +cache. + +## Limitations -1. The API for modules in the `other-modules` (unexposed modules) - sections is not generated or compared. -2. The API of a re-exported module isn't merged with the module that - re-exports it. +1. Modules in `other-modules` are not compared. +2. A symbol re-exported from another module may be reported as removed. + Use `--ignore-module` to suppress known cases. +3. Different GHC or haddock versions render signatures differently, which + shows as false `[~]` changes. Build both refs with the same compiler, + and do not compare `file:` refs made with different compilers. +4. Class methods are not marked in hoogle files. A function that directly + follows a class and has the class as its first constraint is taken to + be a method of that class. -The 2nd limitation might end up falsely reporting a diff even if the diff does -not exist. In our use-case where we have manual intervention this isn't a -problem and does the job well. +See [dev/design.md](dev/design.md) for the design. diff --git a/cabal.project b/cabal.project new file mode 100644 index 0000000..5e8e063 --- /dev/null +++ b/cabal.project @@ -0,0 +1,14 @@ +packages: . + +-- XXX streamly-coreutils is not on Hackage yet. Remove this when it is +-- released (see dev/upstream-fixes.md). +source-repository-package + type: git + location: https://github.com/composewell/streamly-coreutils + tag: 9daf64da9868c8e6bed11d51bcff45bf6e0b0a93 + +tests: True + +-- Limit the heap used by GHC when compiling. +program-options + ghc-options: +RTS -M1500m -RTS diff --git a/cabal.project.Werror b/cabal.project.Werror index 341ecff..058bf46 100644 --- a/cabal.project.Werror +++ b/cabal.project.Werror @@ -1,4 +1,4 @@ -packages: . +import: cabal.project package packdiff ghc-options: -Werror diff --git a/cli/Main.hs b/cli/Main.hs index c3838dc..9897568 100644 --- a/cli/Main.hs +++ b/cli/Main.hs @@ -10,341 +10,7 @@ module Main ( main ) where --------------------------------------------------------------------------------- --- Imports --------------------------------------------------------------------------------- - -import Control.Monad (when) -import Data.Function ((&)) -import Data.List (isInfixOf) -import Streamly.Data.Stream (Stream) -import System.Environment (getArgs) - --- import Debug.Trace (trace) - -import qualified Data.Map as Map -import qualified Streamly.Data.Fold as Fold -import qualified Streamly.Data.Stream as Stream -import qualified Streamly.Internal.FileSystem.FileIO as File -import qualified Streamly.Internal.System.Command as Command -import qualified Streamly.Internal.Unicode.Stream as Unicode -import qualified Streamly.FileSystem.Path as Path - -import Diff -import HoogleFileParser -import Pretty - --------------------------------------------------------------------------------- --- Helpers --------------------------------------------------------------------------------- - -step :: String -> IO () -step msg = do - putStrLn $ unlines - [ "" - , "---------------------------------" - , msg - , "---------------------------------" - ] - --------------------------------------------------------------------------------- --- Main --------------------------------------------------------------------------------- - -checkoutRevision :: String -> IO () -checkoutRevision rev = - let cmd = unwords ["git checkout", rev] - in Command.toStdout cmd - -generateHoogleFile :: String -> String -> IO (Maybe String) -generateHoogleFile target bd = - let cmd = - unwords - [ "cabal haddock" - , target - , "--haddock-hoogle" - , "--builddir=" ++ bd - ] - in Command.toLines Fold.toList cmd & Stream.fold Fold.latest - --- XXX Cache the file for ther version by default. -checkoutAndGenerateHoogleFile :: String -> String -> IO (Maybe String) -checkoutAndGenerateHoogleFile target rev = do - step $ unwords ["Generating haddock file for", rev] - checkoutRevision rev - generateHoogleFile target ("dist-newstyle-" ++ rev) - -fileToLines :: String -> Stream IO String -fileToLines path = - File.readChunks (Path.fromString_ path) & Unicode.decodeUtf8Chunks - & Stream.foldMany (Fold.takeEndBy_ (== '\n') Fold.toList) - -isDeprecated :: [Annotation] -> Bool -isDeprecated anns = - let f x = - case x of - Deprecated _ -> True - _ -> False - in not $ null $ filter f anns - -isInternal :: ModuleName -> Bool -isInternal x = "Internal" `isInfixOf` x - -mainSingle :: [String] -> IO () -mainSingle args = do - when (length args < 2) $ fail "Need a target and a revision." - let target = args !! 0 - rev1 = args !! 1 - (Just file1) <- checkoutAndGenerateHoogleFile target rev1 - putStrLn $ unwords ["File for", rev1, ":", file1] - api1 <- - fileToLines file1 - & Stream.fold (haddockParseFold Added Added Added) - & fmap - (mapAPITags - (mapAttachment (DRight . parseDoc)) - (mapAttachment (DRight . parseDoc)) - (mapAttachment (DRight . parseDoc))) - let elems = - [ ELClasses - , ELDataTypes True - , ELFixities - , ELInstances True - , ELNewTypes True - , ELPatterns - , ELTypeAliases - , ELFunctions - ] - let isDeprecatedInRight (Tagged (Attach (DRight anns) _) _) = - isDeprecated anns - isDeprecatedInRight (Tagged (Attach (DBoth _ anns) _) _) = - isDeprecated anns - isDeprecatedInRight _ = False - - let apiReleased = - Map.filterWithKey - (\k v -> not (isInternal k) && not (isDeprecatedInRight v)) - api1 - let apiInternal = - Map.filterWithKey (\k _ -> isInternal k) api1 - - step "Released API" - putStrLn $ prettyAPI elems apiReleased - step "Internal API" - putStrLn $ prettyAPI elems apiInternal - -mainDiff :: [String] -> IO () -mainDiff args = do - when (length args < 4) - $ fail "target1 revision-for-target1 target2 revision-for-target-2" - let target1 = args !! 0 - revTarget1 = args !! 1 - target2 = args !! 2 - revTarget2 = args !! 3 - (Just file1) <- checkoutAndGenerateHoogleFile target1 revTarget1 - (Just file2) <- checkoutAndGenerateHoogleFile target2 revTarget2 - putStrLn $ unwords ["File for", target1, revTarget1, ":", file1] - putStrLn $ unwords ["File for", target2, revTarget2, ":", file2] - api1 <- - fileToLines file1 - & Stream.fold (haddockParseFold Removed Removed Removed) - & fmap - (mapAPITags - (mapAttachment (DLeft . parseDoc)) - (mapAttachment (DLeft . parseDoc)) - (mapAttachment (DLeft . parseDoc))) - api2 <- - fileToLines file2 & Stream.fold (haddockParseFold Added Added Added) - & fmap - (mapAPITags - (mapAttachment (DRight . parseDoc)) - (mapAttachment (DRight . parseDoc)) - (mapAttachment (DRight . parseDoc))) - - step "API Annotations" - putStrLn "[A] : Added" - putStrLn "[R] : Removed" - putStrLn "[C] : Changed" - putStrLn "[O] : Old definition" - putStrLn "[N] : New definition" - putStrLn "[D] : Deprecated" - - let elems = - [ ELClasses - , ELDataTypes True - , ELFixities - , ELInstances True - , ELNewTypes True - , ELPatterns - , ELTypeAliases - , ELFunctions - ] - let isDeprecatedInBoth (Tagged (Attach (DBoth annl annr) _) _) = - isDeprecated annl && isDeprecated annr - isDeprecatedInBoth _ = False - - isDeprecatedInLeft (Tagged (Attach (DLeft anns) _) _) = - isDeprecated anns - isDeprecatedInLeft (Tagged (Attach (DBoth anns _) _) _) = - isDeprecated anns - isDeprecatedInLeft _ = False - let diffRel = - let filt k v = - not (isInternal k) - && not (isDeprecatedInBoth v || isDeprecatedInLeft v) - in Map.filterWithKey filt (diffAPI api1 api2) - let diffInt = - let filt k _ = isInternal k - in Map.filterWithKey filt (diffAPI api1 api2) - step "API diff" - putStrLn $ prettyAPI elems diffRel - step "Internal API diff" - putStrLn $ prettyAPI elems diffInt +import qualified PackDiff.Main main :: IO () -main = do - args <- getArgs - when (length args < 1) $ fail "Need a mode. [single] or [diff]." - let mode = args !! 0 - case mode of - "single" -> mainSingle (tail args) - "diff" -> mainDiff (tail args) - _ -> error "Improper mode." - - --- TODO: - --- Deprecated in previous release but not in this release --- Deprecated in this release and in previous release --- Deprecated in this release - --- APIs that don't have since annotations --- APIs that don't have complexity annotations --- APIs that have any Pre-release or Internal annotations - --- inspect module, individual elements - --- Breaking changes: API in the released modules that existed before but is --- changed now. --- - Get released modules from (streamly:0.8.3) --- - Get released modules from (streamly:master + streamly-core:master) --- - Filter out modules that have been deprecated in (streamly:0.8.3) --- - Filter out APIs that have been deprecated in (streamly:0.8.3) - -{- - - -main :: IO () -main = do - (Just file083) <- - checkoutAndGenerateHoogleFile "streamly" "v0.8.3" - (Just fileMaster) <- - checkoutAndGenerateHoogleFile "streamly" "release-tasks" - (Just fileCore) <- - checkoutAndGenerateHoogleFile "streamly-core" "release-tasks" - step "Hoogle files" - putStrLn file083 - putStrLn fileMaster - putStrLn fileCore - api083 <- - fileToLines file083 - & Stream.fold (haddockParseFold Removed Removed Removed) - & fmap - (mapAPITags - (mapAttachment (DLeft . parseDoc)) - (mapAttachment (DLeft . parseDoc)) - (mapAttachment (DLeft . parseDoc))) - apiMaster <- - fileToLines fileMaster - & Stream.fold (haddockParseFold Added Added Added) - & fmap - (mapAPITags - (mapAttachment (DRight . parseDoc)) - (mapAttachment (DRight . parseDoc)) - (mapAttachment (DRight . parseDoc))) - apiCore <- - fileToLines fileCore & Stream.fold (haddockParseFold Added Added Added) - & fmap - (mapAPITags - (mapAttachment (DRight . parseDoc)) - (mapAttachment (DRight . parseDoc)) - (mapAttachment (DRight . parseDoc))) - let api = mergeNonConflictingAPI apiMaster apiCore - let isDeprecated anns = - let f x = - case x of - Deprecated _ -> True - _ -> False - in not $ null $ filter f anns - - isDeprecatedInBoth (Tagged (Attach (DBoth annl annr) _) _) = - isDeprecated annl && isDeprecated annr - isDeprecatedInBoth _ = False - - isDeprecatedInLeft (Tagged (Attach (DLeft anns) _) _) = - isDeprecated anns - isDeprecatedInLeft (Tagged (Attach (DBoth anns _) _) _) = - isDeprecated anns - isDeprecatedInLeft _ = False - - existsInBoth (Tagged (Attach (DBoth _ _) _) _) = True - existsInBoth _ = False - - isDeprecatedInRight (Tagged (Attach (DRight anns) _) _) = - isDeprecated anns - isDeprecatedInRight (Tagged (Attach (DBoth _ anns) _) _) = - isDeprecated anns - isDeprecatedInRight _ = False - - isInternal x = "Internal" `isInfixOf` x - - isNew (Tagged (Attach (DRight _) _) _) = True - isNew _ = False - - let api083Exposed = Map.filterWithKey (\k v -> not (isInternal k)) api083 - let apiExposed = Map.filterWithKey (\k v -> not (isInternal k)) api - - let diff0 = diffAPI api083Exposed apiExposed - - let diff1 = - Map.filterWithKey - (\k v -> not (isDeprecatedInBoth v) && existsInBoth v) - diff0 - - let diff2 = Map.filterWithKey (\k v -> isDeprecatedInRight v) diff1 - - let diff3 = - Map.filterWithKey - (\k v -> k == "Streamly.Network.Socket") - diff1 - - let elems = - [ ELClasses - , ELDataTypes True - , ELFixities - , ELInstances True - , ELNewTypes True - , ELPatterns - , ELTypeAliases - , ELFunctions - ] - - -- putStrLn $ prettyAPI elems diff1 - - putStrLn - $ printer - $ prettyMC - elems - (diffModuleContext - (untag (api083Exposed Map.! "Streamly.Prelude")) - (foldl1 - mergeModulesLeaningLeft $ - map untag - [ apiExposed Map.! "Streamly.Data.Stream" - , apiExposed Map.! "Streamly.Data.Stream.Concurrent" - , apiExposed Map.! "Streamly.Data.Stream.Exception" - , apiExposed Map.! "Streamly.Data.Stream.Time" - , apiExposed Map.! "Streamly.Data.Fold" - ])) - --} +main = PackDiff.Main.main diff --git a/dev/upstream-fixes.md b/dev/upstream-fixes.md new file mode 100644 index 0000000..c3777af --- /dev/null +++ b/dev/upstream-fixes.md @@ -0,0 +1,62 @@ +# Upstream fixes and backports needed by packdiff + +Workarounds in packdiff for missing facilities in the streamly ecosystem. +Each one is marked with an `XXX` comment at the place of use. + +## streamly-core + +* Backport `dropCommonPrefixBy` (`Streamly.Internal.Data.Stream`, on + master, not in any release) to 0.3.x. packdiff uses it to highlight the + differing parts of `-` and `+` lines; until then it drops the common + prefix of two lists with local code (`PackDiff.Pretty.dropCommonPrefix`). + +## streamly-process + +* Wait for the child process when a process stream is aborted by an + exception. `cleanupException` sends SIGTERM to the child and reaps it in + a forked thread, so the code after the exception, e.g. deleting the work + clone or restoring a branch, can run while the child is still running. + An option such as `waitOnException` (with a timeout and SIGKILL) would + fix this. packdiff works around it: + * Ctrl-C: `interruptChildOnly True` delivers SIGINT to the child only; + the process library raises `UserInterrupt` after the child exits. + * SIGTERM/SIGHUP: deleting the work directory is retried a few times + (`PackDiff.WorkDir.removeTree`). +* `ProcessFailure` carries only the exit code. The program name and + arguments would make the error message useful; packdiff wraps every + call to add them (`PackDiff.Process.withFailure`). The source already + has a TODO for this. + +## streamly-coreutils + +* Release on Hackage. packdiff pins master (`9daf64d`) with a + `source-repository-package` in `cabal.project`, which a Hackage release + of packdiff cannot depend on. +* A process liveness check (`kill -0` on POSIX, `OpenProcess` on Windows) + and the current process id. packdiff implements both with `unix`/`Win32` + and CPP (`PackDiff.WorkDir`). +* Path versions of the `directory` functions packdiff uses: + `getXdgDirectory`, `doesPathExist`, `doesFileExist`, + `doesDirectoryExist` and `makeAbsolute`. coreutils functions take a + streamly `Path` while these take a `FilePath`, so packdiff converts at + each call. +* Converting signals to exceptions: installing SIGTERM/SIGHUP handlers + (and the Windows console handler) that throw to the main thread so that + `bracket` cleanups run (`PackDiff.Signals`). This is a general facility + for any program that cleans up on exit. + +## streamly-packages flake + +* Update `streamly-coreutils` in `sources.nix` to a revision with the + `Coreutils.*` namespace (`9daf64d` or later); the pinned `fa18006` still + uses `Streamly.Coreutils.*`. +* Make `optparse-applicative`, `ansi-terminal` and `hspec` available to + the packdiff dev shell. + +Until then, build in the nix shell with the user cabal config, which can +fetch the missing packages from Hackage: + +```sh +env -u CABAL_CONFIG cabal build all +env -u CABAL_CONFIG cabal test +``` diff --git a/packdiff.cabal b/packdiff.cabal index e040fc5..cf22c5c 100644 --- a/packdiff.cabal +++ b/packdiff.cabal @@ -38,6 +38,10 @@ extra-doc-files: README.md , CHANGELOG.md , dev/design.md + , dev/upstream-fixes.md +extra-source-files: + test/data/*.txt + , test/golden/*.out source-repository head type: git @@ -58,28 +62,61 @@ common compile-options -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-unsafe + -Wno-safe -Wno-x-partial library import: compile-options - exposed-modules: HoogleFileParser - , Diff - , Pretty - -- other-extensions: - build-depends: base >= 4.10 && < 4.23 - , streamly-core >= 0.1.0 && < 0.4 - , containers >= 0.6 && < 0.9 + exposed-modules: + PackDiff.API + , PackDiff.HoogleFileParser + , PackDiff.Diff + , PackDiff.Classify + , PackDiff.Filter + , PackDiff.Pretty + , PackDiff.Error + , PackDiff.Hash + , PackDiff.Process + , PackDiff.Ref + , PackDiff.Git + , PackDiff.Cabal + , PackDiff.WorkDir + , PackDiff.Signals + , PackDiff.Cache + , PackDiff.Obtain + , PackDiff.Options + , PackDiff.Main + build-depends: + base >= 4.10 && < 4.23 + , ansi-terminal >= 1.0 && < 1.2 + , containers >= 0.6 && < 0.9 + , directory >= 1.3 && < 1.4 + , optparse-applicative >= 0.17 && < 0.20 + , streamly-core >= 0.3 && < 0.4 + , streamly-coreutils >= 0.1 && < 0.2 + , streamly-process >= 0.4 && < 0.5 + if os(windows) + build-depends: Win32 >= 2.6 && < 2.15 + else + build-depends: unix >= 2.7 && < 2.9 hs-source-dirs: src - default-language: Haskell2010 executable packdiff import: compile-options main-is: Main.hs - -- other-extensions: build-depends: base - , streamly-core - , streamly-process >= 0.3.1 && < 0.5 , packdiff - , containers hs-source-dirs: cli - default-language: Haskell2010 + ghc-options: -threaded + +test-suite packdiff-test + import: compile-options + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test + build-depends: base + , containers + , hspec >= 2.7 && < 2.12 + , packdiff + , streamly-core + ghc-options: -with-rtsopts=-M512m diff --git a/src/Diff.hs b/src/Diff.hs deleted file mode 100644 index d97f1c6..0000000 --- a/src/Diff.hs +++ /dev/null @@ -1,180 +0,0 @@ --- | --- Module : Diff --- Copyright : (c) 2022 Composewell Technologies --- License : BSD-3-Clause --- Maintainer : streamly@composewell.com --- Stability : released --- Portability : GHC - -module Diff - ( StatusTag(..) - , diffAPI - , diffModuleContext - , Diff(..) - ) where - --------------------------------------------------------------------------------- --- Imports --------------------------------------------------------------------------------- - -import Data.Map (Map) - -import qualified Data.Map.Strict as SMap - -import HoogleFileParser - --------------------------------------------------------------------------------- --- Types --------------------------------------------------------------------------------- - -data StatusTag new - = Added - | Removed - | Changed new - | Same - deriving (Eq, Ord) - -data Diff a - = DLeft a - | DRight a - | DBoth a a - deriving (Show) - --- Left leaning diff -mergeDiff :: Diff a -> Diff a -> Diff a -mergeDiff (DLeft l) (DRight r) = DBoth l r -mergeDiff l _ = l - -diffIsEq :: (a -> a -> Bool) -> Diff a -> Diff a -> Bool -diffIsEq eq (DLeft l) (DRight r) = eq l r -diffIsEq _ _ _ = undefined - -diffIsEqDoc :: Diff [Annotation] -> Diff [Annotation] -> Bool -diffIsEqDoc l r = diffIsEq (==) l r - --------------------------------------------------------------------------------- --- Diffing --------------------------------------------------------------------------------- - -diffStatusTaggedMap :: - (Ord k) - => (Tagged t v -> Tagged t v -> Tagged t v) - -> Map k (Tagged t v) - -> Map k (Tagged t v) - -> Map k (Tagged t v) -diffStatusTaggedMap unionFunction m1 m2 = - SMap.unionWith unionFunction m1 m2 - --- Generalize the [Annotation] part by supplying a comparision function -unionFunctionDepth0 :: - Tagged (Attach (Diff [Annotation]) (StatusTag EntityContextType)) EntityContextType - -> Tagged (Attach (Diff [Annotation]) (StatusTag EntityContextType)) EntityContextType - -> Tagged (Attach (Diff [Annotation]) (StatusTag EntityContextType)) EntityContextType -unionFunctionDepth0 (Tagged (Attach l _) v1) (Tagged (Attach r _) v2) = - if v1 /= v2 || not (diffIsEqDoc l r) - then Tagged (Attach (mergeDiff l r) (Changed v2)) v1 - else Tagged (Attach (mergeDiff l r) Same) v1 - -unionFunctionDepth1 :: - Tagged (Attach (Diff [Annotation]) (StatusTag ())) (Map String (Tagged (Attach (Diff [Annotation]) (StatusTag EntityContextType)) EntityContextType)) - -> Tagged (Attach (Diff [Annotation]) (StatusTag ())) (Map String (Tagged (Attach (Diff [Annotation]) (StatusTag EntityContextType)) EntityContextType)) - -> Tagged (Attach (Diff [Annotation]) (StatusTag ())) (Map String (Tagged (Attach (Diff [Annotation]) (StatusTag EntityContextType)) EntityContextType)) -unionFunctionDepth1 (Tagged (Attach l _) v1) (Tagged (Attach r _) v2) = - let diffedMap = diffStatusTaggedMap unionFunctionDepth0 v1 v2 - in if hasTagOtherThanSame diffedMap || not (diffIsEqDoc l r) - then Tagged (Attach (mergeDiff l r) (Changed ())) diffedMap - else Tagged (Attach (mergeDiff l r) Same) diffedMap - -hasTagOtherThanSame :: Map k (Tagged (Attach a (StatusTag n)) v) -> Bool -hasTagOtherThanSame = SMap.foldl step initial - - where - - initial = False - - step _ (Tagged (Attach _ (Changed _)) _) = True - step _ (Tagged (Attach _ Added) _) = True - step _ (Tagged (Attach _ Removed) _) = True - step b _ = b - -diffModuleContext :: - ModuleContext (Attach (Diff [Annotation]) (StatusTag ())) (Attach (Diff [Annotation]) (StatusTag EntityContextType)) String EntityContextType - -> ModuleContext (Attach (Diff [Annotation]) (StatusTag ())) (Attach (Diff [Annotation]) (StatusTag EntityContextType)) String EntityContextType - -> ModuleContext (Attach (Diff [Annotation]) (StatusTag ())) (Attach (Diff [Annotation]) (StatusTag EntityContextType)) String EntityContextType -diffModuleContext m1 m2 = - let diffClasses = - diffStatusTaggedMap unionFunctionDepth0 (mClasses m1) (mClasses m2) - diffDataTypes = - diffStatusTaggedMap - unionFunctionDepth1 - (mDataTypes m1) - (mDataTypes m2) - diffFixities = - diffStatusTaggedMap - unionFunctionDepth0 - (mFixities m1) - (mFixities m2) - diffInstances = - diffStatusTaggedMap - unionFunctionDepth1 - (mInstances m1) - (mInstances m2) - diffNewTypes = - diffStatusTaggedMap - unionFunctionDepth1 - (mNewTypes m1) - (mNewTypes m2) - diffPatterns = - diffStatusTaggedMap - unionFunctionDepth0 - (mPatterns m1) - (mPatterns m2) - diffTypeAliases = - diffStatusTaggedMap - unionFunctionDepth0 - (mTypeAliases m1) - (mTypeAliases m2) - diffFunctions = - diffStatusTaggedMap - unionFunctionDepth0 - (mFunctions m1) - (mFunctions m2) - in ModuleContext - { mClasses = diffClasses - , mDataTypes = diffDataTypes - , mFixities = diffFixities - , mInstances = diffInstances - , mNewTypes = diffNewTypes - , mPatterns = diffPatterns - , mTypeAliases = diffTypeAliases - , mFunctions = diffFunctions - } - -unionFunctionDepth2 :: - Tagged (Attach (Diff [Annotation]) (StatusTag ())) (ModuleContext (Attach (Diff [Annotation]) (StatusTag ())) (Attach (Diff [Annotation]) (StatusTag EntityContextType)) String EntityContextType) - -> Tagged (Attach (Diff [Annotation]) (StatusTag ())) (ModuleContext (Attach (Diff [Annotation]) (StatusTag ())) (Attach (Diff [Annotation]) (StatusTag EntityContextType)) String EntityContextType) - -> Tagged (Attach (Diff [Annotation]) (StatusTag ())) (ModuleContext (Attach (Diff [Annotation]) (StatusTag ())) (Attach (Diff [Annotation]) (StatusTag EntityContextType)) String EntityContextType) -unionFunctionDepth2 (Tagged (Attach l _) m1) (Tagged (Attach r _) m2) = - let diffedMC = diffModuleContext m1 m2 - newTag = - if hasTagOtherThanSame (mFunctions diffedMC) - || hasTagOtherThanSame (mTypeAliases diffedMC) - || hasTagOtherThanSame (mPatterns diffedMC) - || hasTagOtherThanSame (mNewTypes diffedMC) - || hasTagOtherThanSame (mInstances diffedMC) - || hasTagOtherThanSame (mFixities diffedMC) - || hasTagOtherThanSame (mDataTypes diffedMC) - || hasTagOtherThanSame (mClasses diffedMC) - || not (diffIsEqDoc l r) - then Changed () - else Same - in Tagged (Attach (mergeDiff l r) newTag) -- XXX Diff between the strings - -- for doc here. - $ diffedMC - --- unionFunctionDepth3 if Tagged -diffAPI :: - API (Attach (Diff [Annotation]) (StatusTag ())) (Attach (Diff [Annotation]) (StatusTag ())) (Attach (Diff [Annotation]) (StatusTag EntityContextType)) - -> API (Attach (Diff [Annotation]) (StatusTag ())) (Attach (Diff [Annotation]) (StatusTag ())) (Attach (Diff [Annotation]) (StatusTag EntityContextType)) - -> API (Attach (Diff [Annotation]) (StatusTag ())) (Attach (Diff [Annotation]) (StatusTag ())) (Attach (Diff [Annotation]) (StatusTag EntityContextType)) -diffAPI api1 api2 = diffStatusTaggedMap unionFunctionDepth2 api1 api2 diff --git a/src/HoogleFileParser.hs b/src/HoogleFileParser.hs deleted file mode 100644 index 8f7a0ba..0000000 --- a/src/HoogleFileParser.hs +++ /dev/null @@ -1,523 +0,0 @@ --- | --- Module : HoogleFileParser --- Copyright : (c) 2022 Composewell Technologies --- License : BSD-3-Clause --- Maintainer : streamly@composewell.com --- Stability : released --- Portability : GHC - -module HoogleFileParser - ( -- Types - FixityType(..) - , ModuleName - , Doc - - -- Attachments - , Attach(..) - , mapAttachment - - -- Tags - , Tagged(..) - , untag - - -- Lowest level context - , EntityContextType(..) - , showECT - - -- Module context - , ModuleContext(..) - , ModuleContextDefault - , NameWithContextDefault - , defModuleContext - , mergeModulesLeaningLeft - - -- API - , API - , mapAPITags - - -- API combinators - , mergeNonConflictingAPI - - -- Additional attached information - , Annotation(..) - , parseDoc - - -- Hoogle file parser - , haddockParseFold - - -- Helpers - , stripBegin - ) where - --------------------------------------------------------------------------------- --- Imports --------------------------------------------------------------------------------- - -import Control.Applicative ((<|>)) -import Data.Char (isUpper) -import Data.List (isPrefixOf) -import Data.Map (Map) -import Streamly.Data.Fold (Fold) -import System.IO.Unsafe (unsafePerformIO) - -import qualified Data.Map as Map -import qualified Data.Map.Strict as SMap -import qualified Streamly.Data.Fold as Fold -import qualified Streamly.Data.Parser as Parser -import qualified Streamly.Data.Stream as Stream - --- import Debug.Trace (trace) - --------------------------------------------------------------------------------- --- Types --------------------------------------------------------------------------------- - -data FixityType - = FixityD - | FixityL - | FixityR - deriving (Eq, Ord, Show) - -type ModuleName = String - -type Doc = String - -data Attach b a = Attach b a - -mapAttachment :: (a -> b) -> Attach a c -> Attach b c -mapAttachment f (Attach a c) = (Attach (f a) c) - -data Tagged t v = - Tagged t v - deriving (Show) - -untag :: Tagged t v -> v -untag (Tagged _ v) = v - -data EntityContextType - = ECFixity (FixityType, Int) - | ECString String - deriving (Eq, Show) - -showECT :: EntityContextType -> String -showECT (ECFixity x) = show x -showECT (ECString x) = x - -data ModuleContext t2 t1 k v = - ModuleContext - { mClasses :: Map k (Tagged t1 v) - , mDataTypes :: Map k (Tagged t2 (Map k (Tagged t1 v))) - , mFixities :: Map k (Tagged t1 v) - , mInstances :: Map k (Tagged t2 (Map k (Tagged t1 v))) - , mNewTypes :: Map k (Tagged t2 (Map k (Tagged t1 v))) - , mPatterns :: Map k (Tagged t1 v) - , mTypeAliases :: Map k (Tagged t1 v) - , mFunctions :: Map k (Tagged t1 v) - } - -type ModuleContextDefault t2 t1 - = ModuleContext t2 t1 String EntityContextType - -type NameWithContextDefault t - = Map String (Tagged t EntityContextType) - -defModuleContext :: ModuleContextDefault t2 t1 -defModuleContext = - ModuleContext - { mClasses = Map.empty - , mDataTypes = Map.empty - , mFixities = Map.empty - , mInstances = Map.empty - , mNewTypes = Map.empty - , mPatterns = Map.empty - , mTypeAliases = Map.empty - , mFunctions = Map.empty - } - --- | API of a package. -type API t3 t2 t1 = Map ModuleName (Tagged t3 (ModuleContextDefault t2 t1)) - -mapAPITags :: - (t3 -> s3) -> (t2 -> s2) -> (t1 -> s1) -> API t3 t2 t1 -> API s3 s2 s1 -mapAPITags f3 f2 f1 api = Map.map (fmapTagged f3 fmapTaggedMC) api - - where - - fmapTagged ft fv (Tagged t val) = Tagged (ft t) (fv val) - - fmapTaggedMC mc = - mc - { mClasses = Map.map (fmapTagged f1 id) (mClasses mc) - , mDataTypes = - Map.map - (fmapTagged f2 (Map.map (fmapTagged f1 id))) - (mDataTypes mc) - , mFixities = Map.map (fmapTagged f1 id) (mFixities mc) - , mInstances = - Map.map - (fmapTagged f2 (Map.map (fmapTagged f1 id))) - (mInstances mc) - , mNewTypes = - Map.map - (fmapTagged f2 (Map.map (fmapTagged f1 id))) - (mNewTypes mc) - , mPatterns = Map.map (fmapTagged f1 id) (mPatterns mc) - , mTypeAliases = Map.map (fmapTagged f1 id) (mTypeAliases mc) - , mFunctions = Map.map (fmapTagged f1 id) (mFunctions mc) - } - -_mapAPITagsPropogate :: - (t3 -> s3) - -> (t3 -> t2 -> s2) - -> (t3 -> t2 -> t1 -> s1) - -> (t3 -> t1 -> s1) - -> API t3 t2 t1 - -> API s3 s2 s1 -_mapAPITagsPropogate _f3 _f2 _f1 _f1_ _api = undefined -{- - Map.map (fmapTagged f3 fmapTaggedMC) api - - where - - fmapTagged ft fv (Tagged t val) = Tagged (ft t) (fv t val) - - fmapTagged1 t3 ft fv (Tagged t val) = Tagged (ft t) (fv t val) - - fmapTagged2 t3 t2 ft fv (Tagged t val) = Tagged (ft t) (fv t val) - - fmapTaggedMC t3 mc = - mc - { mClasses = Map.map (fmapTagged1 t3 (f1_ t3) (flip const)) (mClasses mc) - , mDataTypes = - Map.map - (fmapTagged1 t3 (f2 t3) (\t3 t2 -> Map.map (fmapTagged2 f1 id))) - (mDataTypes mc) - , mFixities = Map.map (fmapTagged f1 id) (mFixities mc) - , mInstances = - Map.map - (fmapTagged f2 (Map.map (fmapTagged f1 id))) - (mInstances mc) - , mNewTypes = - Map.map - (fmapTagged f2 (Map.map (fmapTagged f1 id))) - (mNewTypes mc) - , mPatterns = Map.map (fmapTagged f1 id) (mPatterns mc) - , mTypeAliases = Map.map (fmapTagged f1 id) (mTypeAliases mc) - , mFunctions = Map.map (fmapTagged f1 id) (mFunctions mc) - } --} - -data Annotation - = Complexity String - | Since String - | Deprecated String - | OtherAnn String - deriving (Show, Eq) - -parseDoc :: String -> [Annotation] -parseDoc = map parseAnnotation . getItalics . clenseToWords - - where - - parseAnnotation wrd - | "Since" `isPrefixOf` wrd = Since wrd - | "O" `isPrefixOf` wrd = Complexity wrd - | "Deprecated" `isPrefixOf` wrd = Deprecated wrd - | otherwise = OtherAnn wrd - - getItalics = - let parseItalicAfterItalic = - Parser.manyTill (Parser.one) (Parser.listEq "") Fold.toList - parserBeforeItalic = - Parser.manyTill (Parser.one) (Parser.listEq "") Fold.drain - mapStr x - | null x = Nothing - | otherwise = Just x - parser = - (mapStr <$> (parserBeforeItalic *> parseItalicAfterItalic)) - <|> (const Nothing <$> (Parser.fromFold Fold.drain)) - fromParserResult = either (error . show) id - in unsafePerformIO - . Stream.fold Fold.toList - . Stream.catMaybes - . fmap fromParserResult - . Stream.parseMany parser . Stream.fromList - clenseToWords = - unwords . map removeIntroHyphens . filter (not . null) . lines - - removeIntroHyphens ('-':'-':' ':'|':rest) = rest - removeIntroHyphens ('-':'-':rest) = rest - removeIntroHyphens line = error $ "Incorrectly parsed: " ++ line - -mergeNonConflictingAPI :: API t3 t2 t1 -> API t3 t2 t1 -> API t3 t2 t1 -mergeNonConflictingAPI = - SMap.unionWithKey (\k -> error ("Conflicting module name " ++ k)) - -mergeModulesLeaningLeft :: - ModuleContextDefault t2 t1 - -> ModuleContextDefault t2 t1 - -> ModuleContextDefault t2 t1 -mergeModulesLeaningLeft mcl mcr = - ModuleContext - { mClasses = Map.union (mClasses mcl) (mClasses mcr) - , mDataTypes = Map.union (mDataTypes mcl) (mDataTypes mcr) - , mFixities = Map.union (mFixities mcl) (mFixities mcr) - , mInstances = Map.union (mInstances mcl) (mInstances mcr) - , mNewTypes = Map.union (mNewTypes mcl) (mNewTypes mcr) - , mPatterns = Map.union (mPatterns mcl) (mPatterns mcr) - , mTypeAliases = Map.union (mTypeAliases mcl) (mTypeAliases mcr) - , mFunctions = Map.union (mFunctions mcl) (mFunctions mcr) - } - --------------------------------------------------------------------------------- --- Parsing --------------------------------------------------------------------------------- - --- XXX This could have been much cleaner if there was backtracking in folds -data ParsingModuleState t3 t2 t1 - = PNone (API (Attach Doc t3) (Attach Doc t2) (Attach Doc t1)) - | InModuleContext - String -- Doc level 2 - (API (Attach Doc t3) (Attach Doc t2) (Attach Doc t1)) - ModuleName - (ModuleContextDefault (Attach Doc t2) (Attach Doc t1)) - | InDataTypeContext - String -- Doc level 2 - String -- Doc level 1 - (API (Attach Doc t3) (Attach Doc t2) (Attach Doc t1)) - ModuleName - (ModuleContextDefault (Attach Doc t2) (Attach Doc t1)) - String - (NameWithContextDefault (Attach Doc t1)) - | InNewTypeContext - String -- Doc level 2 - String -- Doc level 1 - (API (Attach Doc t3) (Attach Doc t2) (Attach Doc t1)) - ModuleName - (ModuleContextDefault (Attach Doc t2) (Attach Doc t1)) - String - (NameWithContextDefault (Attach Doc t1)) - -takeWord :: String -> String -takeWord = takeWhile (/= ' ') . dropWhile (== ' ') - -dropWord :: String -> String -dropWord = dropWhile (/= ' ') . dropWhile (== ' ') - -stripBegin :: String -> String -stripBegin = dropWhile (== ' ') - -withDocInitialize :: a -> (String, a) -withDocInitialize a = ("", a) - -haddockParseFold :: - Monad m - => t3 - -> t2 - -> t1 - -> Fold m String (API (Attach Doc t3) (Attach Doc t2) (Attach Doc t1)) -haddockParseFold tag3 tag2 tag1 = extract <$> Fold.foldl' step initial - - where - - mapperStr doc = Tagged (Attach doc tag1) . ECString - - mapperFix doc = Tagged (Attach doc tag1) . ECFixity - - mCtxAp doc api name ctx = Map.insert name (Tagged (Attach doc tag3) ctx) api - - dtCtxAp doc ctx dname dctx = - ctx - { mDataTypes = - Map.insert - dname - (Tagged (Attach doc tag2) dctx) - (mDataTypes ctx) - } - - tCtxAp doc ctx dname dctx = - ctx - { mNewTypes = - Map.insert - dname - (Tagged (Attach doc tag2) dctx) - (mNewTypes ctx) - } - - extract (_, PNone api) = api - extract (_, InModuleContext doc2 api name ctx) = mCtxAp doc2 api name ctx - extract (_, InDataTypeContext doc2 doc1 api mname mctx dname dctx) = - mCtxAp doc2 api mname (dtCtxAp doc1 mctx dname dctx) - extract (_, InNewTypeContext doc2 doc1 api mname mctx dname dctx) = - mCtxAp doc2 api mname (tCtxAp doc1 mctx dname dctx) - - initial = ("", PNone Map.empty) - getAfterTypeCtx = reverse . takeWhile (/= '>') . reverse . dropWord - getW1AfterTypeCtx = takeWord . getAfterTypeCtx - getRestAfterTypeCtx = stripBegin . dropWord . getAfterTypeCtx - getClassName = getW1AfterTypeCtx - getInstanceOf = getW1AfterTypeCtx - getInstanceFor = getRestAfterTypeCtx - getRestAfterW2 = stripBegin . dropWord . dropWord - getW2 = takeWord . dropWord - - stepOtherScope doc2 doc1 doc constr applier api name ctx dname dctx line - | isUpper (head line) || (head line == '[') = - let newDCtx = Map.insert (takeWord line) (mapperStr doc line) dctx - in withDocInitialize $ constr doc2 doc1 api name ctx dname newDCtx - | otherwise = - let newCtx = applier doc1 ctx dname dctx - in step_ doc (InModuleContext doc2 api name newCtx) line - - stepModuleScope doc2 doc api name ctx line - | "module " `isPrefixOf` line = - withDocInitialize - $ InModuleContext - doc - (mCtxAp doc2 api name ctx) - (getW2 line) - defModuleContext - | "class " `isPrefixOf` line = - withDocInitialize - $ InModuleContext doc2 api name - $ ctx - { mClasses = - Map.insert - (getClassName line) - (mapperStr doc line) - (mClasses ctx) - } - | "instance " `isPrefixOf` line = - let singMap = - Tagged (Attach "" tag2) - $ Map.singleton - (getInstanceFor line) - (mapperStr doc line) - - insertF (Tagged (Attach "" _) a) (Tagged (Attach "" _) b) = - Tagged (Attach "" tag2) (SMap.union a b) - insertF _ _ = error "Instance level 1 has doc" - in withDocInitialize - $ InModuleContext doc2 api name - $ ctx - { mInstances = - SMap.insertWith - insertF - (getInstanceOf line) - singMap - (mInstances ctx) - } - | "data " `isPrefixOf` line = - withDocInitialize - $ InDataTypeContext doc2 doc api name ctx (getW2 line) Map.empty - | "type " `isPrefixOf` line = - withDocInitialize - $ InModuleContext doc2 api name - $ ctx - { mTypeAliases = - Map.insert - (getW2 line) - (mapperStr doc line) - (mTypeAliases ctx) - } - | "newtype " `isPrefixOf` line = - withDocInitialize - $ InNewTypeContext doc2 doc api name ctx (getW2 line) Map.empty - | "infixl " `isPrefixOf` line = - withDocInitialize - $ InModuleContext doc2 api name - $ ctx - { mFixities = - Map.insert - (getRestAfterW2 line) - (mapperFix doc (FixityL, read (getW2 line))) - (mFixities ctx) - } - | "infixr " `isPrefixOf` line = - withDocInitialize - $ InModuleContext doc2 api name - $ ctx - { mFixities = - Map.insert - (getRestAfterW2 line) - (mapperFix doc (FixityR, read (getW2 line))) - (mFixities ctx) - } - | "infix " `isPrefixOf` line = - withDocInitialize - $ InModuleContext doc2 api name - $ ctx - { mFixities = - Map.insert - (getRestAfterW2 line) - (mapperFix doc (FixityD, read (getW2 line))) - (mFixities ctx) - } - | "pattern " `isPrefixOf` line = - withDocInitialize - $ InModuleContext doc2 api name - $ ctx - { mPatterns = - Map.insert - (getW2 line) - (mapperStr doc line) - (mPatterns ctx) - } - | otherwise = - withDocInitialize - $ InModuleContext doc2 api name - $ ctx - { mFunctions = - Map.insert - (takeWord line) - (mapperStr doc line) - (mFunctions ctx) - } - - step_ doc st line - | "@" `isPrefixOf` line = ("", st) - | "--" `isPrefixOf` line = (unlines [doc, line], st) - | null line = (unlines [doc, line], st) - | line == "\n" = (unlines [doc, line], st) - | otherwise = - case st of - -- Shift to a new module context from nothing - PNone api -> - if "module" `isPrefixOf` line - then withDocInitialize - $ InModuleContext - doc - api - (drop 7 line) - defModuleContext - else (doc, PNone api) - InModuleContext doc2 api name ctx -> - stepModuleScope doc2 doc api name ctx line - InDataTypeContext doc2 doc1 api mname mctx dname dctx -> - stepOtherScope - doc2 - doc1 - doc - InDataTypeContext - dtCtxAp - api - mname - mctx - dname - dctx - line - InNewTypeContext doc2 doc1 api mname mctx dname dctx -> - stepOtherScope - doc2 - doc1 - doc - InNewTypeContext - tCtxAp - api - mname - mctx - dname - dctx - line - - step (doc, st) = step_ doc st diff --git a/src/PackDiff/API.hs b/src/PackDiff/API.hs new file mode 100644 index 0000000..8417785 --- /dev/null +++ b/src/PackDiff/API.hs @@ -0,0 +1,115 @@ +-- | +-- Module : PackDiff.API +-- Copyright : (c) 2022 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- The API of a package, as described by a hoogle file. + +module PackDiff.API + ( -- * Declarations + DeclKind (..) + , Child (..) + , Decl (..) + , DeclKey + , declKey + + -- * Modules + , ModuleName + , Module (..) + , moduleSize + + -- * API + , API + , mergeNonConflictingAPI + + -- * Hoogle file + , Hoogle (..) + ) where + +import Data.Map (Map) + +import qualified Data.Map.Strict as Map + +-------------------------------------------------------------------------------- +-- Declarations +-------------------------------------------------------------------------------- + +-- | The kind of a top level declaration. The constructor order is the order in +-- which the kinds are printed. +data DeclKind + = KData -- ^ data type or newtype + | KTypeSyn + | KClass + | KInstance + | KPattern + | KFunction + | KFixity + deriving (Eq, Ord, Show, Enum, Bounded) + +-- | A constructor or field of a data type, or a method of a class. +data Child = Child + { childName :: String + , childText :: String + , childDeprecated :: Bool + } deriving (Eq, Show) + +data Decl = Decl + { declKind :: DeclKind + , declName :: String + -- ^ The name of the entity. For an instance it is the instance head. + , declText :: String + -- ^ The line in the hoogle file. For a data type, newtype or class it is + -- the declaration head. + , declDoc :: [String] + , declDeprecated :: Bool + , declChildren :: [Child] + -- ^ Constructors and fields, or class methods, in hoogle file order. + } deriving (Eq, Show) + +type DeclKey = (DeclKind, String) + +declKey :: Decl -> DeclKey +declKey d = (declKind d, declName d) + +-------------------------------------------------------------------------------- +-- Modules +-------------------------------------------------------------------------------- + +type ModuleName = String + +data Module = Module + { moduleDoc :: [String] + , moduleDeprecated :: Bool + , moduleDecls :: Map DeclKey Decl + } deriving (Eq, Show) + +-- | Number of top level entities in a module. +moduleSize :: Module -> Int +moduleSize = Map.size . moduleDecls + +-------------------------------------------------------------------------------- +-- API +-------------------------------------------------------------------------------- + +type API = Map ModuleName Module + +-- | Union of two APIs that have no module in common. A module present in both +-- is an error. +mergeNonConflictingAPI :: API -> API -> API +mergeNonConflictingAPI = + Map.unionWithKey (\k _ _ -> error ("Conflicting module name " ++ k)) + +-------------------------------------------------------------------------------- +-- Hoogle file +-------------------------------------------------------------------------------- + +-- | A parsed hoogle file. A file made by concatenating the hoogle files of +-- several packages has several @\@package@ and @\@version@ lines. +data Hoogle = Hoogle + { hooglePackages :: [String] + , hoogleVersions :: [String] + , hoogleAPI :: API + } deriving (Eq, Show) diff --git a/src/PackDiff/Cabal.hs b/src/PackDiff/Cabal.hs new file mode 100644 index 0000000..fe4ed7f --- /dev/null +++ b/src/PackDiff/Cabal.hs @@ -0,0 +1,199 @@ +-- | +-- Module : PackDiff.Cabal +-- Copyright : (c) 2022 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- Building hoogle files with cabal, and Hackage releases. + +module PackDiff.Cabal + ( -- * Build configuration + BuildConfig (..) + , compilerProgram + , haddockProgram + , ghcVersion + , haddockVersion + + -- * Hoogle files + , hoogleFileFromOutput + , buildHoogle + + -- * Hackage + , parseVersionList + , latestVersion + , resolveHackageVersion + , cabalGet + ) where + +import Data.Char (isSpace) +import Data.List (isPrefixOf, isSuffixOf, stripPrefix) +import Data.Maybe (fromMaybe, mapMaybe) + +import PackDiff.Classify (Version, parseVersion, showVersion) +import PackDiff.Error (obtainError, onObtainError) +import PackDiff.Process + +-------------------------------------------------------------------------------- +-- Build configuration +-------------------------------------------------------------------------------- + +data BuildConfig = BuildConfig + { bcCompiler :: Maybe String -- ^ @-w@ + , bcCabalOptions :: [String] + } + +compilerProgram :: BuildConfig -> String +compilerProgram = fromMaybe "ghc" . bcCompiler + +-- | The directory part of a path, if any. +directoryOf :: String -> Maybe String +directoryOf p = + case break isSep (reverse p) of + (_, _ : rdir) -> Just (reverse rdir) + (_, []) -> Nothing + + where + + isSep c = c == '/' || c == '\\' + +-- | The haddock program used by cabal for the selected compiler. +-- +-- XXX cabal looks for @haddock-@ and @haddock@ next to the +-- compiler and then in PATH. This uses @haddock@ next to the compiler if the +-- compiler is given as a path, otherwise @haddock@ in PATH. It is used only +-- for the version in the cache key. +haddockProgram :: BuildConfig -> String +haddockProgram bc = + case bcCompiler bc >>= directoryOf of + Just dir -> dir ++ "/haddock" + Nothing -> "haddock" + +ghcVersion :: BuildConfig -> IO String +ghcVersion bc = + fmap trim + (readCmd (Cmd Nothing (compilerProgram bc) ["--numeric-version"])) + +-- | The version in the output of @haddock --version@, e.g. @Haddock version +-- 2.30.0, (c) ...@. +haddockVersion :: BuildConfig -> IO String +haddockVersion bc = do + out <- readCmd (Cmd Nothing (haddockProgram bc) ["--version"]) + `onObtainError` + readCmd (Cmd Nothing "haddock" ["--version"]) + pure $ case words out of + ("Haddock" : "version" : v : _) -> takeWhile (/= ',') v + _ -> trim (takeWhile (/= '\n') out) + +trim :: String -> String +trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace + +-------------------------------------------------------------------------------- +-- Hoogle files +-------------------------------------------------------------------------------- + +-- | The hoogle file in the output of @cabal haddock --haddock-hoogle@: the +-- last path ending in @.txt@ after @Documentation created:@. +-- +-- XXX cabal does not provide a machine readable way to find the generated +-- hoogle file, so its human readable output is used. +hoogleFileFromOutput :: String -> Maybe FilePath +hoogleFileFromOutput out = + case filter (".txt" `isSuffixOf`) (concatMap candidates (lines out)) of + [] -> Nothing + xs -> Just (last xs) + + where + + candidates l = + let t = trim l + in case stripPrefix "Documentation created:" t of + Just rest -> [trim rest] + Nothing -> [t | not (null t)] + +-- | Run @cabal haddock --haddock-hoogle@ in a directory and return the path of +-- the generated hoogle file. +buildHoogle :: + BuildConfig + -> FilePath -- ^ directory to run cabal in + -> Maybe String -- ^ target package + -> Maybe FilePath -- ^ build directory + -> IO FilePath +buildHoogle bc dir target builddir = do + out <- runCmd (Cmd (Just dir) "cabal" args) + case hoogleFileFromOutput out of + Just path + | isAbsolute path -> pure path + | otherwise -> pure (dir ++ "/" ++ path) + Nothing -> + obtainError $ + "could not find the hoogle file in the output of cabal haddock" + ++ " in " ++ dir + + where + + args = + ["haddock"] + ++ maybe [] pure target + ++ ["--haddock-hoogle"] + ++ maybe [] (\d -> ["--builddir=" ++ d]) builddir + ++ maybe [] (\c -> ["--with-compiler=" ++ c]) (bcCompiler bc) + ++ bcCabalOptions bc + isAbsolute p = + "/" `isPrefixOf` p + || case p of + (_ : ':' : _) -> True -- Windows drive + _ -> "\\" `isPrefixOf` p + +-------------------------------------------------------------------------------- +-- Hackage +-------------------------------------------------------------------------------- + +-- | Versions of a package in the output of @cabal list --simple-output@, one +-- @ @ line per version. Other packages matching the search are +-- skipped. +parseVersionList :: String -> String -> [Version] +parseVersionList pkg out = + mapMaybe version (lines out) + + where + + version l = + case words l of + [p, v] | p == pkg -> parseVersion v + _ -> Nothing + +latestVersion :: [Version] -> Maybe Version +latestVersion [] = Nothing +latestVersion vs = Just (maximum vs) + +-- | Resolve a Hackage version from cabal's local package index. 'Nothing' +-- selects the latest version. +resolveHackageVersion :: String -> Maybe String -> IO String +resolveHackageVersion pkg mver = do + out <- readCmd (Cmd Nothing "cabal" ["list", "--simple-output", pkg]) + `onObtainError` pure "" + let versions = parseVersionList pkg out + case mver of + Nothing -> + maybe notFound (pure . showVersion) (latestVersion versions) + Just v + | Just pv <- parseVersion v, pv `elem` versions -> pure v + | otherwise -> notFound + + where + + what = maybe pkg (\v -> pkg ++ "-" ++ v) mver + notFound = + obtainError $ + what ++ " not found in cabal's package index; " + ++ "run 'cabal update' if it was released recently" + +-- | Unpack a release with @cabal get@ into a directory, and return the +-- directory of the package source. +cabalGet :: FilePath -> String -> String -> IO FilePath +cabalGet dir pkg ver = do + let pkgver = pkg ++ "-" ++ ver + _ <- runCmd (Cmd (Just dir) "cabal" ["get", pkgver, "--destdir=" ++ dir]) + pure (dir ++ "/" ++ pkgver) diff --git a/src/PackDiff/Cache.hs b/src/PackDiff/Cache.hs new file mode 100644 index 0000000..a1294cc --- /dev/null +++ b/src/PackDiff/Cache.hs @@ -0,0 +1,78 @@ +-- | +-- Module : PackDiff.Cache +-- Copyright : (c) 2022 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- Cache of hoogle files in @$XDG_CACHE_HOME/packdiff/hoogle@. Entries are +-- never evicted. + +module PackDiff.Cache + ( CacheKey (..) + , cacheFileName + , cacheLookup + , cacheStore + ) where + +import System.Directory (XdgDirectory(..), doesFileExist, getXdgDirectory) + +import qualified Coreutils.Cp as Cp +import qualified Coreutils.Mkdir as Mkdir +import qualified Coreutils.Mv as Mv +import qualified Streamly.FileSystem.Path as Path + +import PackDiff.Hash (hashHex) +import PackDiff.WorkDir (currentPid) + +data CacheKey = CacheKey + { ckPackage :: String + -- ^ package name, or the subdirectory when no package is given + , ckRevision :: String -- ^ commit SHA or Hackage version + , ckGhcVersion :: String + , ckHaddockVersion :: String + , ckCabalOptions :: [String] + } deriving (Show) + +-- | A readable name with a hash of the cabal options. Characters that are +-- not safe in a file name are replaced. +cacheFileName :: CacheKey -> String +cacheFileName k = + concatMap safe (ckPackage k) ++ "-" ++ concatMap safe (ckRevision k) + ++ "-ghc-" ++ ckGhcVersion k + ++ "-haddock-" ++ ckHaddockVersion k + ++ "-" ++ hashHex (show (ckCabalOptions k)) + ++ ".txt" + + where + + safe c + | c `elem` "/\\:*?\"<>| " = "_" + | otherwise = [c] + +cacheDir :: IO FilePath +cacheDir = fmap (++ "/hoogle") (getXdgDirectory XdgCache "packdiff") + +cachePath :: CacheKey -> IO FilePath +cachePath k = fmap (\d -> d ++ "/" ++ cacheFileName k) cacheDir + +cacheLookup :: CacheKey -> IO (Maybe FilePath) +cacheLookup k = do + path <- cachePath k + exists <- doesFileExist path + pure (if exists then Just path else Nothing) + +-- | Copy a hoogle file into the cache and return the path of the entry. The +-- entry is written to a temporary file and renamed into place, so that a +-- concurrent run never reads a partly written entry. +cacheStore :: CacheKey -> FilePath -> IO FilePath +cacheStore k src = do + dir <- cacheDir + Mkdir.mkdir (Mkdir.makeParents True) (Path.fromString_ dir) + path <- cachePath k + pid <- currentPid + let tmp = path ++ ".tmp-" ++ show pid + Cp.cp id (Path.fromString_ src) (Path.fromString_ tmp) + Mv.mv (Mv.force True) (Path.fromString_ tmp) (Path.fromString_ path) + pure path diff --git a/src/PackDiff/Classify.hs b/src/PackDiff/Classify.hs new file mode 100644 index 0000000..9442390 --- /dev/null +++ b/src/PackDiff/Classify.hs @@ -0,0 +1,129 @@ +-- | +-- Module : PackDiff.Classify +-- Copyright : (c) 2022 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- Classification of changes as breaking or non-breaking, and the PVP version +-- bump required by a diff. + +module PackDiff.Classify + ( -- * Breaking changes + isBreakingChild + , isBreakingDecl + , moduleBreakingCount + , breakingCount + + -- * Versions + , Version + , parseVersion + , showVersion + , compareVersion + , Bump (..) + , requiredBump + , bumpVersion + ) where + +import Data.Char (isDigit) + +import PackDiff.Diff + +-------------------------------------------------------------------------------- +-- Breaking changes +-------------------------------------------------------------------------------- + +isStructural :: Change -> Bool +isStructural c = c `elem` [Added, Removed, Changed] + +-- | An added, removed or changed constructor, field or method changes the +-- definition of its data type or class. +isBreakingChild :: ChildDiff -> Bool +isBreakingChild = isStructural . cdChange + +-- | Removals and changes of definitions are breaking. A declaration whose only +-- change is the deprecation of some of its children is not. +-- +-- An added orphan instance is breaking under the PVP, but the hoogle file +-- does not mark orphan instances, so added instances are non-breaking. +isBreakingDecl :: DeclDiff -> Bool +isBreakingDecl dd = + case ddChange dd of + Removed -> True + Changed -> declHeadChanged dd || any isBreakingChild (ddChildren dd) + _ -> False + +-- | A removed module counts as one breaking change. +moduleBreakingCount :: ModuleDiff -> Int +moduleBreakingCount md = + case mdChange md of + Removed -> 1 + _ -> length (filter isBreakingDecl (mdDecls md)) + +breakingCount :: [ModuleDiff] -> Int +breakingCount = sum . map moduleBreakingCount + +-------------------------------------------------------------------------------- +-- Versions +-------------------------------------------------------------------------------- + +type Version = [Int] + +parseVersion :: String -> Maybe Version +parseVersion s + | null s = Nothing + | otherwise = mapM readComponent (splitDots s) + + where + + splitDots str = + case break (== '.') str of + (a, []) -> [a] + (a, _ : rest) -> a : splitDots rest + readComponent c + | not (null c) && all isDigit c = Just (read c) + | otherwise = Nothing + +showVersion :: Version -> String +showVersion = foldr1 (\a b -> a ++ "." ++ b) . map show + +-- | Compare versions, treating missing components as zero, so that @1.2@ and +-- @1.2.0.0@ are equal. +compareVersion :: Version -> Version -> Ordering +compareVersion a b = compare (pad a) (pad b) + + where + + n = max (length a) (length b) + pad v = v ++ replicate (n - length v) 0 + +-- | PVP version bumps, for versions of the form @A.B.C.D@. +data Bump + = BumpMajor -- ^ @A.B@ + | BumpMinor -- ^ @C@ + | BumpPatch -- ^ @D@ + deriving (Eq, Show) + +-- | Any breaking change requires a major bump, any other change a minor bump. +requiredBump :: [ModuleDiff] -> Bump +requiredBump mds + | breakingCount mds > 0 = BumpMajor + | not (null mds) = BumpMinor + | otherwise = BumpPatch + +-- | The smallest version with the given bump, e.g. @1.3.0.0@ for a major bump +-- of @1.2.0.0@. +bumpVersion :: Bump -> Version -> Version +bumpVersion bump v = + case bump of + BumpMajor -> [a, b + 1, 0, 0] + BumpMinor -> [a, b, c + 1, 0] + BumpPatch -> [a, b, c, d + 1] + + where + + (a, b, c, d) = + case v ++ repeat 0 of + (x1 : x2 : x3 : x4 : _) -> (x1, x2, x3, x4) + _ -> error "bumpVersion: unreachable" diff --git a/src/PackDiff/Diff.hs b/src/PackDiff/Diff.hs new file mode 100644 index 0000000..cad69ba --- /dev/null +++ b/src/PackDiff/Diff.hs @@ -0,0 +1,170 @@ +-- | +-- Module : PackDiff.Diff +-- Copyright : (c) 2022 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- Difference between two APIs. Definitions are compared textually. + +module PackDiff.Diff + ( Change (..) + , ChildDiff (..) + , DeclDiff (..) + , declDiffDecl + , declHeadChanged + , ModuleDiff (..) + , moduleDiffModule + , APIDiff + , diffAPI + ) where + +import Control.Applicative ((<|>)) +import Data.Map (Map) +import Data.Maybe (fromMaybe, isNothing, mapMaybe) + +import qualified Data.Map.Strict as Map +import qualified Data.Map.Merge.Strict as Merge + +import PackDiff.API + +-------------------------------------------------------------------------------- +-- Types +-------------------------------------------------------------------------------- + +-- | The constructor order is the order of the sections in the output grouped +-- by change. +data Change + = Removed + | Changed + | Deprecated + | Undeprecated + | Added + deriving (Eq, Ord, Show, Enum, Bounded) + +data ChildDiff = ChildDiff + { cdChange :: Change + , cdOld :: Maybe Child + , cdNew :: Maybe Child + } deriving (Eq, Show) + +-- | A 'Changed' declaration has changed in its own definition, in its +-- children, or both. +data DeclDiff = DeclDiff + { ddChange :: Change + , ddOld :: Maybe Decl + , ddNew :: Maybe Decl + , ddChildren :: [ChildDiff] + } deriving (Eq, Show) + +-- | The new declaration, or the old one if it was removed. +declDiffDecl :: DeclDiff -> Decl +declDiffDecl dd = + fromMaybe (error "declDiffDecl: empty") (ddNew dd <|> ddOld dd) + +-- | Whether the declaration line itself (not its children) changed. +declHeadChanged :: DeclDiff -> Bool +declHeadChanged dd = + case (ddOld dd, ddNew dd) of + (Just o, Just n) -> declText o /= declText n + _ -> False + +data ModuleDiff = ModuleDiff + { mdChange :: Change + , mdOld :: Maybe Module + , mdNew :: Maybe Module + , mdDecls :: [DeclDiff] + -- ^ Changed declarations, sorted by kind and name. + } deriving (Eq, Show) + +-- | The new module, or the old one if it was removed. +moduleDiffModule :: ModuleDiff -> Module +moduleDiffModule md = + fromMaybe (error "moduleDiffModule: empty") (mdNew md <|> mdOld md) + +-- | Changed modules only. +type APIDiff = Map ModuleName ModuleDiff + +-------------------------------------------------------------------------------- +-- Diffing +-------------------------------------------------------------------------------- + +deprecationChange :: Bool -> Bool -> Maybe Change +deprecationChange False True = Just Deprecated +deprecationChange True False = Just Undeprecated +deprecationChange _ _ = Nothing + +diffChild :: Child -> Child -> Maybe ChildDiff +diffChild o n + | childText o /= childText n = Just (ChildDiff Changed (Just o) (Just n)) + | otherwise = + fmap + (\c -> ChildDiff c (Just o) (Just n)) + (deprecationChange (childDeprecated o) (childDeprecated n)) + +-- | Children present in the new declaration are in their new order, followed +-- by the removed ones in their old order. +diffChildren :: [Child] -> [Child] -> [ChildDiff] +diffChildren old new = mapMaybe inNew new ++ removed + + where + + byName = Map.fromList . map (\c -> (childName c, c)) + oldMap = byName old + newMap = byName new + + inNew n = + case Map.lookup (childName n) oldMap of + Nothing -> Just (ChildDiff Added Nothing (Just n)) + Just o -> diffChild o n + + removed = + [ ChildDiff Removed (Just o) Nothing + | o <- old + , isNothing (Map.lookup (childName o) newMap) + ] + +diffDecl :: Decl -> Decl -> Maybe DeclDiff +diffDecl o n + | declText o /= declText n || not (null children) = + Just (DeclDiff Changed (Just o) (Just n) children) + | otherwise = + fmap + (\c -> DeclDiff c (Just o) (Just n) []) + (deprecationChange (declDeprecated o) (declDeprecated n)) + + where + + children = diffChildren (declChildren o) (declChildren n) + +diffDecls :: Map DeclKey Decl -> Map DeclKey Decl -> [DeclDiff] +diffDecls old new = + Map.elems + $ Merge.merge + (Merge.mapMissing (\_ o -> DeclDiff Removed (Just o) Nothing [])) + (Merge.mapMissing (\_ n -> DeclDiff Added Nothing (Just n) [])) + (Merge.zipWithMaybeMatched (\_ o n -> diffDecl o n)) + old + new + +diffModule :: Module -> Module -> Maybe ModuleDiff +diffModule o n = + case deprecationChange (moduleDeprecated o) (moduleDeprecated n) of + Just c -> Just (mk c) + Nothing + | null decls -> Nothing + | otherwise -> Just (mk Changed) + + where + + decls = diffDecls (moduleDecls o) (moduleDecls n) + mk c = ModuleDiff c (Just o) (Just n) decls + +-- | @diffAPI old new@. +diffAPI :: API -> API -> APIDiff +diffAPI = + Merge.merge + (Merge.mapMissing (\_ o -> ModuleDiff Removed (Just o) Nothing [])) + (Merge.mapMissing (\_ n -> ModuleDiff Added Nothing (Just n) [])) + (Merge.zipWithMaybeMatched (\_ o n -> diffModule o n)) diff --git a/src/PackDiff/Error.hs b/src/PackDiff/Error.hs new file mode 100644 index 0000000..faacc79 --- /dev/null +++ b/src/PackDiff/Error.hs @@ -0,0 +1,49 @@ +-- | +-- Module : PackDiff.Error +-- Copyright : (c) 2022 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- Errors and their exit codes. + +module PackDiff.Error + ( PackDiffError (..) + , usageError + , obtainError + , errorExitCode + , onObtainError + ) where + +import Control.Exception (Exception(..), catch, throwIO) + +data PackDiffError + = UsageError String + -- ^ Wrong usage, including a missing external program. + | ObtainError String + -- ^ Failure to obtain an API: a failed git or cabal command, a build + -- failure or a hoogle file parse error. + deriving Show + +instance Exception PackDiffError where + displayException (UsageError msg) = msg + displayException (ObtainError msg) = msg + +usageError :: String -> IO a +usageError = throwIO . UsageError + +obtainError :: String -> IO a +obtainError = throwIO . ObtainError + +errorExitCode :: PackDiffError -> Int +errorExitCode (UsageError _) = 2 +errorExitCode (ObtainError _) = 3 + +-- | Run the handler if the action throws an 'ObtainError'. +onObtainError :: IO a -> IO a -> IO a +onObtainError action handler = + action `catch` \e -> + case e of + ObtainError _ -> handler + UsageError _ -> throwIO e diff --git a/src/PackDiff/Filter.hs b/src/PackDiff/Filter.hs new file mode 100644 index 0000000..52803b1 --- /dev/null +++ b/src/PackDiff/Filter.hs @@ -0,0 +1,146 @@ +-- | +-- Module : PackDiff.Filter +-- Copyright : (c) 2022 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- Module selection, change type selection and the @--fail-on@ check. + +module PackDiff.Filter + ( -- * Globs + Glob + , globMatch + + -- * Modules + , ModuleFilter (..) + , defaultInternalGlobs + , selectModules + , isInternal + , partitionInternal + + -- * Change types + , parseChangeTypes + , parseFailOn + , changeTypeNames + , hasChangeIn + ) where + +import Data.Map (Map) +import Data.Set (Set) + +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set + +import PackDiff.API (API, ModuleName) +import PackDiff.Diff + +-------------------------------------------------------------------------------- +-- Globs +-------------------------------------------------------------------------------- + +-- | A glob in which @*@ matches any sequence of characters, including dots. +type Glob = String + +globMatch :: Glob -> String -> Bool +globMatch ('*' : gs) s = any (globMatch gs) (suffixes s) + + where + + suffixes xs = xs : case xs of + [] -> [] + (_ : rest) -> suffixes rest +globMatch (g : gs) (c : cs) = g == c && globMatch gs cs +globMatch [] [] = True +globMatch _ _ = False + +-------------------------------------------------------------------------------- +-- Modules +-------------------------------------------------------------------------------- + +data ModuleFilter = ModuleFilter + { mfInclude :: [Glob] -- ^ empty means all modules + , mfExclude :: [Glob] + , mfInternal :: [Glob] + } + +defaultInternalGlobs :: [Glob] +defaultInternalGlobs = ["*.Internal.*", "*.Internal"] + +matchesAny :: [Glob] -> ModuleName -> Bool +matchesAny globs m = any (`globMatch` m) globs + +-- | Keep the modules selected by @--module@ and @--ignore-module@. +selectModules :: ModuleFilter -> API -> API +selectModules mf = Map.filterWithKey (\k _ -> selected k) + + where + + selected m = + (null (mfInclude mf) || matchesAny (mfInclude mf) m) + && not (matchesAny (mfExclude mf) m) + +isInternal :: ModuleFilter -> ModuleName -> Bool +isInternal mf = matchesAny (mfInternal mf) + +-- | (released, internal) +partitionInternal :: ModuleFilter -> Map ModuleName a -> (Map ModuleName a, Map ModuleName a) +partitionInternal mf = Map.partitionWithKey (\k _ -> not (isInternal mf k)) + +-------------------------------------------------------------------------------- +-- Change types +-------------------------------------------------------------------------------- + +changeTypeNames :: [(String, Change)] +changeTypeNames = + [ ("added", Added) + , ("removed", Removed) + , ("changed", Changed) + , ("deprecated", Deprecated) + , ("undeprecated", Undeprecated) + ] + +splitCommas :: String -> [String] +splitCommas s = + case break (== ',') s of + (a, []) -> [a] + (a, _ : rest) -> a : splitCommas rest + +-- | Parse a comma separated list of change types, given extra names. +parseWith :: [(String, [Change])] -> String -> Either String (Set Change) +parseWith extra s = fmap (Set.fromList . concat) (mapM one (splitCommas s)) + + where + + names = [(n, [c]) | (n, c) <- changeTypeNames] ++ extra + one name = + case lookup name names of + Just cs -> Right cs + Nothing -> + Left $ "unknown change type " ++ show name ++ ", expected one of: " + ++ unwordsComma (map fst names) + unwordsComma = foldr1 (\a b -> a ++ ", " ++ b) + +-- | Values of @--show@ and @--hide@. +parseChangeTypes :: String -> Either String (Set Change) +parseChangeTypes = parseWith [] + +-- | Values of @--fail-on@: change types, @breaking@ and @any@. +parseFailOn :: String -> Either String (Set Change) +parseFailOn = + parseWith + [ ("breaking", [Removed, Changed]) + , ("any", [minBound .. maxBound]) + ] + +-- | Whether a module, declaration or child change of these types is present. +hasChangeIn :: Set Change -> [ModuleDiff] -> Bool +hasChangeIn cs = any inModule + + where + + has c = c `Set.member` cs + inModule md = has (mdChange md) || any inDecl (mdDecls md) + inDecl dd = has (ddChange dd) || any (has . cdChange) (ddChildren dd) + diff --git a/src/PackDiff/Git.hs b/src/PackDiff/Git.hs new file mode 100644 index 0000000..472935e --- /dev/null +++ b/src/PackDiff/Git.hs @@ -0,0 +1,145 @@ +-- | +-- Module : PackDiff.Git +-- Copyright : (c) 2022 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- The git commands used by packdiff. + +module PackDiff.Git + ( Sha + -- * Queries + , topLevel + , prefix + , resolveLocal + , resolveRemote + , matchRemoteRef + , hasTrackedChanges + , currentBranch + + -- * Work clones + , cloneShared + , initRepo + , fetchSha + , checkout + ) where + +import Data.Char (isHexDigit, isSpace) +import Data.Maybe (listToMaybe) + +import PackDiff.Error (onObtainError, usageError) +import PackDiff.Process + +type Sha = String + +git :: FilePath -> [String] -> Cmd +git dir args = Cmd (Just dir) "git" args + +trim :: String -> String +trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace + +firstLine :: String -> String +firstLine = trim . takeWhile (/= '\n') + +-------------------------------------------------------------------------------- +-- Queries +-------------------------------------------------------------------------------- + +-- | The top level directory of the repository containing a directory. +topLevel :: FilePath -> IO FilePath +topLevel dir = + fmap firstLine (readCmd (git dir ["rev-parse", "--show-toplevel"])) + `onObtainError` usageError ("not in a git repository: " ++ dir) + +-- | The path of a directory relative to the top level directory of its +-- repository, with a trailing slash, or empty at the top level. +prefix :: FilePath -> IO FilePath +prefix dir = fmap firstLine (readCmd (git dir ["rev-parse", "--show-prefix"])) + +-- | Resolve a revision to a commit SHA in a local repository. +resolveLocal :: FilePath -> String -> IO Sha +resolveLocal repo rev = + fmap firstLine + (readCmd (git repo ["rev-parse", "--verify", "--quiet", rev ++ "^{commit}"])) + `onObtainError` + usageError ("unknown git revision " ++ show rev ++ " in " ++ repo) + +isFullSha :: String -> Bool +isFullSha s = length s == 40 && all isHexDigit s + +-- | Find a revision in the output of @git ls-remote@: a branch, a tag (the +-- commit of an annotated tag), @HEAD@, a full ref name, or a full SHA. +matchRemoteRef :: [String] -> String -> Maybe Sha +matchRemoteRef out rev + | isFullSha rev = Just rev + | otherwise = + listToMaybe + [ sha + | name <- candidates + , (sha, ref) <- refs + , ref == name + ] + + where + + refs = [(sha, ref) | l <- out, (sha, '\t' : ref) <- [break (== '\t') l]] + candidates = + [ rev + , "refs/tags/" ++ rev ++ "^{}" + , "refs/tags/" ++ rev + , "refs/heads/" ++ rev + ] + +-- | Resolve a branch, tag or full SHA of a remote repository with +-- @git ls-remote@. +resolveRemote :: FilePath -> String -> String -> IO Sha +resolveRemote cwd url rev + | isFullSha rev = pure rev + | otherwise = do + out <- readCmdLines (git cwd ["ls-remote", url]) + case matchRemoteRef out rev of + Just sha -> pure sha + Nothing -> + usageError $ + "revision " ++ show rev ++ " not found in " ++ url + ++ "; a revision of a remote repository must be a " + ++ "branch, a tag or a full commit SHA" + +-- | Whether tracked files have uncommitted changes. +hasTrackedChanges :: FilePath -> IO Bool +hasTrackedChanges repo = + fmap (not . null . trim) + (readCmd (git repo ["status", "--porcelain", "--untracked-files=no"])) + +-- | The current branch, or the SHA if @HEAD@ is detached. +currentBranch :: FilePath -> IO String +currentBranch repo = do + branch <- + fmap firstLine (readCmd (git repo ["symbolic-ref", "--short", "-q", "HEAD"])) + `onObtainError` pure "" + if null branch + then fmap firstLine (readCmd (git repo ["rev-parse", "HEAD"])) + else pure branch + +-------------------------------------------------------------------------------- +-- Work clones +-------------------------------------------------------------------------------- + +-- | @git clone --shared --no-checkout@: the clone reads objects from the +-- source repository through @.git/objects/info/alternates@. +cloneShared :: FilePath -> FilePath -> FilePath -> IO () +cloneShared cwd repo dest = + () <$ runCmd (git cwd ["clone", "-q", "--shared", "--no-checkout", repo, dest]) + +initRepo :: FilePath -> FilePath -> IO () +initRepo cwd dest = () <$ runCmd (git cwd ["init", "-q", dest]) + +-- | Fetch only the files of one commit. +fetchSha :: FilePath -> String -> Sha -> IO () +fetchSha repo url sha = + () <$ runCmd (git repo ["fetch", "-q", "--depth", "1", url, sha]) + +checkout :: FilePath -> String -> IO () +checkout repo rev = () <$ runCmd (git repo ["checkout", "-q", rev]) diff --git a/src/PackDiff/Hash.hs b/src/PackDiff/Hash.hs new file mode 100644 index 0000000..7bd0266 --- /dev/null +++ b/src/PackDiff/Hash.hs @@ -0,0 +1,42 @@ +-- | +-- Module : PackDiff.Hash +-- Copyright : (c) 2022 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- A stable hash for names on disk. The output must not change between +-- versions, therefore @hashable@ is not used. + +module PackDiff.Hash + ( fnv1a64 + , hashHex + ) where + +import Data.Bits (xor) +import Data.Functor.Identity (runIdentity) +import Data.Word (Word64) +import Numeric (showHex) + +import qualified Streamly.Data.Fold as Fold +import qualified Streamly.Data.Stream as Stream +import qualified Streamly.Unicode.Stream as Unicode + +-- | 64-bit FNV-1a of the UTF-8 encoding of a string. +fnv1a64 :: String -> Word64 +fnv1a64 = + runIdentity + . Stream.fold (Fold.foldl' step 0xcbf29ce484222325) + . Unicode.encodeUtf8 + . Stream.fromList + + where + + step h b = (h `xor` fromIntegral b) * 0x100000001b3 + +-- | 'fnv1a64' as 16 hex digits. +hashHex :: String -> String +hashHex s = + let h = showHex (fnv1a64 s) "" + in replicate (16 - length h) '0' ++ h diff --git a/src/PackDiff/HoogleFileParser.hs b/src/PackDiff/HoogleFileParser.hs new file mode 100644 index 0000000..48fcf19 --- /dev/null +++ b/src/PackDiff/HoogleFileParser.hs @@ -0,0 +1,359 @@ +-- | +-- Module : PackDiff.HoogleFileParser +-- Copyright : (c) 2022 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- Parser for the hoogle files generated by haddock. +-- +-- A file made by concatenating several hoogle files is parsed as one API: +-- @\@package@ and @\@version@ lines are collected and each @module@ line +-- starts a new module. A module that appears again replaces the earlier one. + +module PackDiff.HoogleFileParser + ( hoogleFold + , parseHoogleLines + , fileLines + , readHoogleFile + ) where + +import Data.Char (isSpace, isUpper) +import Data.Function ((&)) +import Data.List (isInfixOf, isPrefixOf, stripPrefix) +import Data.Maybe (isNothing) +import Streamly.Data.Fold (Fold) +import Streamly.Data.Stream (Stream) +import Streamly.FileSystem.Path (Path) + +import qualified Data.Map.Strict as Map +import qualified Streamly.Data.Fold as Fold +import qualified Streamly.Data.Stream as Stream +import qualified Streamly.FileSystem.FileIO as File +import qualified Streamly.FileSystem.Path as Path +import qualified Streamly.Unicode.Stream as Unicode + +import PackDiff.API +import PackDiff.Error (obtainError) + +-------------------------------------------------------------------------------- +-- Line classification helpers +-------------------------------------------------------------------------------- + +strip :: String -> String +strip = dropWhileEnd' . dropWhile isSpace + + where + + dropWhileEnd' = reverse . dropWhile isSpace . reverse + +isDeprecatedDoc :: [String] -> Bool +isDeprecatedDoc = any ("Deprecated:" `isInfixOf`) + +-- | The name declared by a line that starts with a keyword, e.g. @data@. A +-- @family@ keyword after it is skipped. +nameAfterKeyword :: String -> String +nameAfterKeyword line = + case words line of + (_ : "family" : n : _) -> n + (_ : n : _) -> n + _ -> line + +-- | The class name in a class declaration head, e.g. @MonadAsync@ in +-- @class Monad m => MonadAsync m@. +className :: String -> String +className line = + let hd = takeWhileNotWhere (drop (length "class ") line) + in case words (afterLastArrow hd) of + (n : _) -> n + [] -> hd + + where + + takeWhileNotWhere s = + case breakOnStr " where" s of + (a, _) -> a + afterLastArrow s = + case breakOnStr "=>" s of + (_, Just rest) -> afterLastArrow rest + (a, Nothing) -> a + +-- | Split at the first occurrence of a separator, dropping the separator. +breakOnStr :: String -> String -> (String, Maybe String) +breakOnStr sep = go [] + + where + + go acc s@(c : cs) = + case stripPrefix sep s of + Just rest -> (reverse acc, Just rest) + Nothing -> go (c : acc) cs + go acc [] = (reverse acc, Nothing) + +-- | The type after @::@ in a signature, without a leading @forall ... .@. +signatureType :: String -> Maybe String +signatureType line = + case breakOnStr " :: " line of + (_, Just ty) -> Just (dropForall ty) + (_, Nothing) -> Nothing + + where + + dropForall ty + | "forall " `isPrefixOf` ty = + case breakOnStr ". " ty of + (_, Just rest) -> rest + (_, Nothing) -> ty + | otherwise = ty + +-- | Whether a line is a constructor or a field of a data type. +isConstructorLine :: String -> Bool +isConstructorLine line = + case line of + (c : _) | isUpper c -> True + ('[' : _) -> True + ('(' : ':' : _) -> True + _ -> False + +-- | Haddock prints the methods of a class just after the class declaration, +-- with the class constraint first in the signature, e.g. @mapEmpty :: IsMap f +-- => f a@ after @class IsMap f@. +-- +-- XXX The hoogle file does not mark class methods. A top level function that +-- directly follows a class and has the same leading constraint is taken to be +-- a method. Haddock interface files (@--show-interface@) would tell exactly. +isMethodOf :: String -> String -> Bool +isMethodOf cls line = + case signatureType line of + Just ty -> + "=>" `isInfixOf` ty + && ((cls ++ " ") `isPrefixOf` ty + || ("(" ++ cls ++ " ") `isPrefixOf` ty) + Nothing -> False + +-------------------------------------------------------------------------------- +-- Parser state +-------------------------------------------------------------------------------- + +-- | A declaration that can still take children from the following lines. +data Open + = OpenNone + | OpenData !Decl + | OpenClass !String !Bool !Decl + -- ^ Class name, whether inside a multi line @where { ... }@, the class. + +data St = St + { stDoc :: ![String] -- reversed + , stPackages :: ![String] -- reversed + , stVersions :: ![String] -- reversed + , stAPI :: !API + , stModule :: !(Maybe (ModuleName, Module)) + , stOpen :: !Open + , stLineNo :: !Int + , stError :: !(Maybe String) + } + +initial :: St +initial = + St + { stDoc = [] + , stPackages = [] + , stVersions = [] + , stAPI = Map.empty + , stModule = Nothing + , stOpen = OpenNone + , stLineNo = 0 + , stError = Nothing + } + +takeDoc :: St -> ([String], St) +takeDoc st = (reverse (stDoc st), st { stDoc = [] }) + +reverseChildren :: Decl -> Decl +reverseChildren d = d { declChildren = reverse (declChildren d) } + +-- | Add the open declaration, if any, to the current module. +closeDecl :: St -> St +closeDecl st = + case stOpen st of + OpenNone -> st + OpenData d -> insertDecl (reverseChildren d) st { stOpen = OpenNone } + OpenClass _ _ d -> + insertDecl (reverseChildren d) st { stOpen = OpenNone } + +insertDecl :: Decl -> St -> St +insertDecl d st = + case stModule st of + Just (name, m) -> + let m1 = m { moduleDecls = Map.insert (declKey d) d (moduleDecls m) } + in st { stModule = Just (name, m1) } + Nothing -> st + +-- | Add the current module, if any, to the API. +closeModule :: St -> St +closeModule st0 = + let st = closeDecl st0 + in case stModule st of + Just (name, m) -> + st { stAPI = Map.insert name m (stAPI st), stModule = Nothing } + Nothing -> st + +-------------------------------------------------------------------------------- +-- Declarations +-------------------------------------------------------------------------------- + +mkDecl :: DeclKind -> String -> String -> [String] -> Decl +mkDecl kind name text doc = + Decl + { declKind = kind + , declName = name + , declText = text + , declDoc = doc + , declDeprecated = isDeprecatedDoc doc + , declChildren = [] + } + +mkChild :: String -> [String] -> Child +mkChild line doc = + Child + { childName = takeWhile (not . isSpace) line + , childText = line + , childDeprecated = isDeprecatedDoc doc + } + +addChild :: String -> St -> St +addChild line st0 = + let (doc, st) = takeDoc st0 + add d = d { declChildren = mkChild line doc : declChildren d } + in case stOpen st of + OpenData d -> st { stOpen = OpenData (add d) } + OpenClass c b d -> st { stOpen = OpenClass c b (add d) } + OpenNone -> st + +-- | A top level declaration line. +topLevel :: String -> St -> St +topLevel line st1 = + let st0 = closeDecl st1 + (doc, st) = takeDoc st0 + insert kind name = insertDecl (mkDecl kind name line doc) st + open kind name = + st { stOpen = OpenData (mkDecl kind name line doc) } + in case words line of + ("data" : _) -> open KData (nameAfterKeyword line) + ("newtype" : _) -> open KData (nameAfterKeyword line) + ("type" : _) -> insert KTypeSyn (nameAfterKeyword line) + ("class" : _) -> + let multiline = "{" `isSuffixOf'` line + cls = className line + in st { stOpen = OpenClass cls multiline (mkDecl KClass cls line doc) } + ("instance" : _) -> + insert KInstance (drop (length "instance ") line) + ("pattern" : _) -> insert KPattern (nameAfterKeyword line) + (fx : _ : ops) + | fx `elem` ["infix", "infixl", "infixr"] -> + insert KFixity (unwords ops) + _ -> insert KFunction (takeWhile (not . isSpace) line) + + where + + isSuffixOf' s x = reverse s `isPrefixOf` reverse x + +-- | A continuation line of a multi line class declaration, e.g. an associated +-- type. It is appended to the class declaration so that the declaration +-- stays on one line. +classContinuation :: String -> St -> St +classContinuation line st = + case stOpen st of + OpenClass c _ d -> + let s = strip line + d1 = d { declText = declText d ++ " " ++ s } + in st { stOpen = OpenClass c (not ("}" `isPrefixOf` s)) d1 } + _ -> st + +-------------------------------------------------------------------------------- +-- Line step +-------------------------------------------------------------------------------- + +stepLine :: St -> String -> St +stepLine st0 line0 = + let st = st0 { stLineNo = stLineNo st0 + 1 } + line = stripCR line0 + in case stError st of + Just _ -> st + Nothing -> go st line + + where + + stripCR s = + case reverse s of + ('\r' : rest) -> reverse rest + _ -> s + + go st line + | OpenClass _ True _ <- stOpen st = classContinuation line st + | Just pkg <- stripPrefix "@package " line = + (closeDecl st) { stPackages = strip pkg : stPackages st, stDoc = [] } + | Just ver <- stripPrefix "@version " line = + (closeDecl st) { stVersions = strip ver : stVersions st, stDoc = [] } + | "@" `isPrefixOf` line = st { stDoc = [] } + | "--" `isPrefixOf` line = st { stDoc = line : stDoc st } + | all isSpace line = st + | Just name <- stripPrefix "module " line = + let (doc, st1) = takeDoc (closeModule st) + m = Module + { moduleDoc = doc + , moduleDeprecated = isDeprecatedDoc doc + , moduleDecls = Map.empty + } + in st1 { stModule = Just (strip name, m) } + | isNothing (stModule st) = + st { stError = Just $ + "line " ++ show (stLineNo st) + ++ ": declaration outside a module: " ++ line } + | otherwise = + case stOpen st of + OpenData _ | isConstructorLine line -> addChild line st + OpenClass cls _ _ | isMethodOf cls line -> addChild line st + _ -> topLevel line st + +extract :: St -> Either String Hoogle +extract st0 = + case stError st0 of + Just err -> Left err + Nothing -> + let st = closeModule st0 + in Right Hoogle + { hooglePackages = reverse (stPackages st) + , hoogleVersions = reverse (stVersions st) + , hoogleAPI = stAPI st + } + +-------------------------------------------------------------------------------- +-- Interface +-------------------------------------------------------------------------------- + +-- | Parse the lines of a hoogle file. +hoogleFold :: Monad m => Fold m String (Either String Hoogle) +hoogleFold = fmap extract (Fold.foldl' stepLine initial) + +parseHoogleLines :: [String] -> Either String Hoogle +parseHoogleLines = extract . foldl stepLine initial + +-- | The lines of a UTF-8 encoded text file. +fileLines :: Path -> Stream IO String +fileLines path = + File.read path + & Unicode.decodeUtf8 + & Stream.foldMany (Fold.takeEndBy_ (== '\n') Fold.toList) + +-- | Read and parse a hoogle file. A parse error is thrown as an +-- 'PackDiff.Error.ObtainError'. +readHoogleFile :: Path -> IO Hoogle +readHoogleFile path = do + r <- fileLines path & Stream.fold hoogleFold + either + (\e -> obtainError $ Path.toString path ++ ": " ++ e) + pure + r + diff --git a/src/PackDiff/Main.hs b/src/PackDiff/Main.hs new file mode 100644 index 0000000..8dda180 --- /dev/null +++ b/src/PackDiff/Main.hs @@ -0,0 +1,353 @@ +{-# LANGUAGE ScopedTypeVariables #-} +-- | +-- Module : PackDiff.Main +-- Copyright : (c) 2022 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- The packdiff program. + +module PackDiff.Main + ( main + , defaultRefs + ) where + +import Control.Exception + ( AsyncException(..) + , Handler(..) + , SomeException(..) + , catches + , displayException + , finally + , throwIO + , uninterruptibleMask_ + ) +import Data.Function ((&)) +import System.Console.ANSI (hSupportsANSI) +import System.Environment (lookupEnv) +import System.Exit (ExitCode(..), exitWith) +import System.IO (hPutStrLn, hSetEncoding, stderr, stdout, utf8) + +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import qualified Streamly.Console.Stdio as Stdio +import qualified Streamly.FileSystem.FileIO as File +import qualified Streamly.FileSystem.Path as Path + +import PackDiff.API +import PackDiff.Cabal (BuildConfig(..)) +import PackDiff.Classify +import PackDiff.Diff +import PackDiff.Error +import PackDiff.Filter +import PackDiff.Obtain +import PackDiff.Options +import PackDiff.Pretty +import PackDiff.Ref +import PackDiff.Signals +import PackDiff.WorkDir + +-------------------------------------------------------------------------------- +-- Refs and repositories +-------------------------------------------------------------------------------- + +-- | Fill in the default refs: @HEAD .@ for diff and check, @.@ for api. +defaultRefs :: Command -> [String] -> Either String [String] +defaultRefs cmd refs = + case (cmd, refs) of + (CmdApi, []) -> Right ["."] + (CmdApi, [r]) -> Right [r] + (CmdApi, _) -> Left "api takes at most one ref" + (_, []) -> Right ["HEAD", "."] + (_, [r1]) -> Right [r1, "."] + (_, [r1, r2]) -> Right [r1, r2] + _ -> Left "diff and check take at most two refs" + +-- | A ref as given on the command line, parsed, with the repository flag +-- that applies to it. +data RefArg = RefArg + { raString :: String + , raRef :: Ref + , raRepoFlag :: Maybe String + } + +-- | Parse the refs and assign the repository flags to them. +refArgs :: Options -> IO [RefArg] +refArgs opts = do + strs <- either usageError pure (defaultRefs (optCommand opts) (optRefs opts)) + refs <- mapM (either usageError pure . parseRef) strs + let flags = + case optCommand opts of + CmdApi -> [optRepo opts] + _ -> [ orElse (optOldRepo opts) (optRepo opts) + , orElse (optNewRepo opts) (optRepo opts) + ] + args = zipWith3 RefArg strs refs flags + checkRepoFlags opts args + pure args + + where + + orElse (Just a) _ = Just a + orElse Nothing b = b + +-- | A repository flag that applies only to refs that are not git refs is a +-- usage error. +checkRepoFlags :: Options -> [RefArg] -> IO () +checkRepoFlags opts args = do + case (optOldRepo opts, args) of + (Just _, a : _) | not (isGitRef (raRef a)) -> + usageError "--old-repo applies only to a git ref, REF1 is not one" + _ -> pure () + case (optNewRepo opts, args) of + (Just _, [_, a]) | not (isGitRef (raRef a)) -> + usageError "--new-repo applies only to a git ref, REF2 is not one" + _ -> pure () + case optRepo opts of + Just _ | not (any (isGitRef . raRef) args) -> + usageError "--repo applies only to git refs, none is given" + _ -> pure () + +repoOf :: RefArg -> IO Repo +repoOf a = maybe (pure RepoCurrent) resolveRepo (raRepoFlag a) + +-------------------------------------------------------------------------------- +-- Obtaining APIs +-------------------------------------------------------------------------------- + +-- | The package name in a hoogle file. +packageNameOf :: RefArg -> Obtained -> IO String +packageNameOf a ob = + case hooglePackages (obHoogle ob) of + [p] -> pure p + _ -> + usageError $ + "cannot take the package name from ref " ++ raString a + ++ "; use --package" + +obtainArg :: Env -> Maybe String -> RefArg -> IO Obtained +obtainArg env pkg a = do + repo <- repoOf a + obtain env repo pkg (raRef a) + +-- | Obtain two refs. Without --package, a Hackage ref takes the package name +-- from the other ref, which is therefore obtained first. +obtainPair :: Env -> Options -> RefArg -> RefArg -> IO (Obtained, Obtained) +obtainPair env opts a1 a2 = + case optPackage opts of + Just p -> (,) <$> obtainArg env (Just p) a1 <*> obtainArg env (Just p) a2 + Nothing + | isHackageRef (raRef a1) && isHackageRef (raRef a2) -> + usageError "--package is required when both refs are Hackage refs" + | isHackageRef (raRef a1) -> do + o2 <- obtainArg env Nothing a2 + p <- packageNameOf a2 o2 + o1 <- obtainArg env (Just p) a1 + pure (o1, o2) + | isHackageRef (raRef a2) -> do + o1 <- obtainArg env Nothing a1 + p <- packageNameOf a1 o1 + o2 <- obtainArg env (Just p) a2 + pure (o1, o2) + | otherwise -> + (,) <$> obtainArg env Nothing a1 <*> obtainArg env Nothing a2 + +-------------------------------------------------------------------------------- +-- Output +-------------------------------------------------------------------------------- + +useColor :: ColorMode -> IO Bool +useColor mode = + case mode of + ColorAlways -> pure True + ColorNever -> pure False + ColorAuto -> do + noColor <- lookupEnv "NO_COLOR" + ansi <- hSupportsANSI stdout + pure (maybe True null noColor && ansi) + +moduleFilter :: Options -> ModuleFilter +moduleFilter opts = + ModuleFilter + { mfInclude = optModules opts + , mfExclude = optIgnoreModules opts + , mfInternal = + case optInternalModules opts of + [] -> defaultInternalGlobs + globs -> globs + } + +-- | Which change types are printed. +visibility :: Options -> IO (Change -> Bool) +visibility opts = + case (shown, optHide opts) of + (Just _, Just _) -> usageError "--show and --hide cannot be used together" + (Just s, Nothing) -> pure (`Set.member` s) + (Nothing, Just h) -> pure (`Set.notMember` h) + (Nothing, Nothing) -> pure (const True) + + where + + breaking = Set.fromList [Removed, Changed] + shown = + case (optShow opts, optBreakingOnly opts) of + (s, False) -> s + (s, True) -> Just (maybe breaking (Set.union breaking) s) + +selectedAPI :: Options -> Obtained -> API +selectedAPI opts = selectModules (moduleFilter opts) . hoogleAPI . obHoogle + +-------------------------------------------------------------------------------- +-- Commands +-------------------------------------------------------------------------------- + +-- | Released and internal module diffs. +diffPair :: Options -> Obtained -> Obtained -> (APIDiff, APIDiff) +diffPair opts o1 o2 = + partitionInternal (moduleFilter opts) + $ diffAPI (selectedAPI opts o1) (selectedAPI opts o2) + +diffCommand :: Env -> Options -> RefArg -> RefArg -> IO ExitCode +diffCommand env opts a1 a2 = do + visible <- visibility opts + color <- useColor (optColor opts) + (o1, o2) <- obtainPair env opts a1 a2 + let (released, internal) = diffPair opts o1 o2 + ro = RenderOptions + { roGroupBy = optGroupBy opts + , roQuiet = optQuiet opts + , roModulesOnly = optModulesOnly opts + , roVisible = visible + } + putStr $ renderLines color (renderDiff ro released internal) + pure $ case optFailOn opts of + Just cs | hasChangeIn cs (Map.elems released) -> ExitFailure 1 + _ -> ExitSuccess + +-- | The version of a ref, from its single @\@version@ line. +versionOf :: RefArg -> Obtained -> IO Version +versionOf a ob = + case hoogleVersions (obHoogle ob) of + [v] | Just ver <- parseVersion v -> pure ver + [v] -> usageError $ "invalid version " ++ show v ++ " in ref " ++ raString a + vs -> + usageError $ + "ref " ++ raString a ++ " has " ++ show (length vs) + ++ " @version lines, check needs exactly one" + +checkCommand :: Env -> Options -> RefArg -> RefArg -> IO ExitCode +checkCommand env opts a1 a2 = do + (o1, o2) <- obtainPair env opts a1 a2 + base <- versionOf a1 o1 + declared <- versionOf a2 o2 + let (released, _) = diffPair opts o1 o2 + mds = Map.elems released + bump = requiredBump mds + required = bumpVersion bump base + sufficient = compareVersion declared required /= LT + reason = + case bump of + BumpMajor -> "breaking changes detected: bump major" + BumpMinor + | hasChangeIn (Set.singleton Added) mds -> + "new symbols added: bump minor" + | otherwise -> "non-breaking changes detected: bump minor" + BumpPatch -> "no API changes detected: bump patch" + putStrLn $ reason ++ " (" ++ showVersion required ++ ")" + putStrLn $ + "declared version " ++ showVersion declared ++ " is " + ++ if sufficient then "sufficient" else "insufficient" + pure (if sufficient then ExitSuccess else ExitFailure 1) + +apiCommand :: Env -> Options -> RefArg -> IO ExitCode +apiCommand env opts a = do + color <- useColor (optColor opts) + ob <- obtainArg env (optPackage opts) a + case optFormat opts of + FormatHoogle -> + File.readChunks (Path.fromString_ (obFile ob)) & Stdio.putChunks + FormatText -> do + let (released, internal) = + partitionInternal (moduleFilter opts) (selectedAPI opts ob) + putStr $ renderLines color (renderAPI released internal) + pure ExitSuccess + +-------------------------------------------------------------------------------- +-- Main +-------------------------------------------------------------------------------- + +run :: Options -> IO ExitCode +run opts = do + args <- refArgs opts + _ <- visibility opts -- report conflicting flags before any work + let bc = BuildConfig (optCompiler opts) (optCabalOptions opts) + checkPrograms + (requiredPrograms bc (optInPlace opts) + [(raString a, raRef a) | a <- args]) + root <- maybe defaultWorkRoot pure (optWorkDir opts) + let cfg = EnvConfig + { ecBuild = bc + , ecPackage = optPackage opts + , ecNoCache = optNoCache opts + , ecInPlace = optInPlace opts + } + withWorkSpace root $ \ws -> do + env <- newEnv cfg ws + let inPlaceRefs = + [ a | a <- args + , raRef a == RefCwd + || isGitRef (raRef a) && raRepoFlag a == Nothing + ] + if optInPlace opts && not (null inPlaceRefs) + then do + checkInPlace env + pinned <- mapM (pin env) args + command env pinned + `finally` uninterruptibleMask_ (restoreInPlace env) + else command env args + + where + + pin env a = do + repo <- repoOf a + ref <- pinRef env repo (raRef a) + pure a { raRef = ref } + + command env args = + case (optCommand opts, args) of + (CmdDiff, [a1, a2]) -> diffCommand env opts a1 a2 + (CmdCheck, [a1, a2]) -> checkCommand env opts a1 a2 + (CmdApi, [a]) -> apiCommand env opts a + _ -> usageError "wrong number of refs" + +-- | All exceptions are reported and mapped to exit code 2 or 3. +main :: IO () +main = do + hSetEncoding stdout utf8 + hSetEncoding stderr utf8 + opts <- parseOptions + code <- + (installTerminationHandlers >> run opts) + `catches` + [ Handler (\(e :: ExitCode) -> throwIO e) + , Handler (\(e :: PackDiffError) -> + failWith (errorExitCode e) (displayException e)) + , Handler (\(Terminated s) -> failWith 3 ("terminated by " ++ s)) + , Handler (\(e :: AsyncException) -> + case e of + UserInterrupt -> failWith 3 "interrupted" + _ -> failWith 3 (displayException e)) + -- The inner exception is displayed without the backtrace that + -- displayException of SomeException adds. + , Handler (\(SomeException e) -> failWith 3 (displayException e)) + ] + exitWith code + + where + + failWith code msg = do + hPutStrLn stderr ("packdiff: " ++ msg) + pure (ExitFailure code) + diff --git a/src/PackDiff/Obtain.hs b/src/PackDiff/Obtain.hs new file mode 100644 index 0000000..b72f754 --- /dev/null +++ b/src/PackDiff/Obtain.hs @@ -0,0 +1,379 @@ +{-# LANGUAGE ScopedTypeVariables #-} +-- | +-- Module : PackDiff.Obtain +-- Copyright : (c) 2022 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- Resolve refs and obtain their hoogle files. + +module PackDiff.Obtain + ( -- * Requirements + requiredPrograms + , checkPrograms + + -- * Environment + , Env + , EnvConfig (..) + , newEnv + , resolveRepo + , checkInPlace + , restoreInPlace + + -- * Obtaining + , Obtained (..) + , pinRef + , obtain + ) where + +import Control.Exception (Handler(..), IOException, catches, throwIO, try) +import Control.Monad (unless, when) +import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef') +import Data.List (nub) +import Data.Map (Map) +import System.Directory (doesDirectoryExist, doesFileExist, makeAbsolute) +import System.IO (hPutStrLn, stderr) + +import qualified Coreutils.Which as Which +import qualified Data.Map.Strict as Map +import qualified Streamly.FileSystem.Path as Path + +import PackDiff.API (Hoogle) +import PackDiff.Cabal +import PackDiff.Cache +import PackDiff.Error +import PackDiff.Git (Sha) +import PackDiff.Hash (hashHex) +import PackDiff.HoogleFileParser (readHoogleFile) +import PackDiff.Ref +import PackDiff.WorkDir + +import qualified PackDiff.Git as Git + +-------------------------------------------------------------------------------- +-- Requirements +-------------------------------------------------------------------------------- + +-- | The programs needed by each ref, as (program, ref) pairs. The ref is the +-- string given on the command line. +requiredPrograms :: BuildConfig -> Bool -> [(String, Ref)] -> [(String, String)] +requiredPrograms bc inPlace = nub . concatMap needs + + where + + build = ["cabal", compilerProgram bc, haddockProgram bc] + needs (s, ref) = + map (\p -> (p, s)) $ + case ref of + RefGit _ -> "git" : build + RefCwd -> [ "git" | inPlace ] ++ build + RefHackage _ -> build + RefFile _ -> [] + +-- | Whether a program exists, given as a name in PATH or as a path. +programExists :: String -> IO Bool +programExists p + | any (`elem` "/\\") p = doesFileExist p + | otherwise = fmap (maybe False (const True)) (Which.which p) + +-- | Exit with a usage error if a program needed by a ref is missing. +checkPrograms :: [(String, String)] -> IO () +checkPrograms = mapM_ check + + where + + check (prog, ref) = do + ok <- programExists prog + unless ok $ + usageError $ + "program " ++ show prog ++ " not found; it is needed for ref " + ++ show ref + +-------------------------------------------------------------------------------- +-- Environment +-------------------------------------------------------------------------------- + +data EnvConfig = EnvConfig + { ecBuild :: BuildConfig + , ecPackage :: Maybe String + , ecNoCache :: Bool + , ecInPlace :: Bool + } + +data Env = Env + { envConfig :: EnvConfig + , envWorkSpace :: WorkSpace + , envCwd :: FilePath + , envCurrentRepo :: IORef (Maybe (FilePath, FilePath)) + -- ^ top level directory and prefix of the current directory + , envClones :: IORef (Map String FilePath) + -- ^ work clone of each repository + , envTools :: IORef (Maybe (String, String)) + -- ^ ghc and haddock versions + , envOriginalBranch :: IORef (Maybe (FilePath, String)) + -- ^ in-place mode: repository and branch to restore + } + +newEnv :: EnvConfig -> WorkSpace -> IO Env +newEnv cfg ws = do + cwd <- makeAbsolute "." + Env cfg ws cwd + <$> newIORef Nothing + <*> newIORef Map.empty + <*> newIORef Nothing + <*> newIORef Nothing + +-- | Memoize an action in an IORef. +cached :: IORef (Maybe a) -> IO a -> IO a +cached ref action = do + m <- readIORef ref + case m of + Just a -> pure a + Nothing -> do + a <- action + writeIORef ref (Just a) + pure a + +currentRepo :: Env -> IO (FilePath, FilePath) +currentRepo env = + cached (envCurrentRepo env) $ do + top <- Git.topLevel (envCwd env) + pre <- Git.prefix (envCwd env) + pure (top, pre) + +toolVersions :: Env -> IO (String, String) +toolVersions env = + cached (envTools env) $ do + let bc = ecBuild (envConfig env) + (,) <$> ghcVersion bc <*> haddockVersion bc + +-- | Resolve the value of a repository flag. +resolveRepo :: String -> IO Repo +resolveRepo s = do + isDir <- doesDirectoryExist s + case classifyRepo isDir s of + Left err -> usageError err + Right (Left dir) -> RepoLocal <$> (makeAbsolute dir >>= Git.topLevel) + Right (Right url) -> pure (RepoRemote url) + +-------------------------------------------------------------------------------- +-- In-place mode +-------------------------------------------------------------------------------- + +-- | Exit with a usage error if tracked files have uncommitted changes. +checkInPlace :: Env -> IO () +checkInPlace env = do + (top, _) <- currentRepo env + dirty <- Git.hasTrackedChanges top + when dirty $ + usageError "--in-place: tracked files have uncommitted changes" + +-- | Check out a revision in the current working tree. The current branch is +-- recorded and printed before the first checkout. +inPlaceCheckout :: Env -> FilePath -> Sha -> IO () +inPlaceCheckout env top sha = do + orig <- readIORef (envOriginalBranch env) + case orig of + Just _ -> pure () + Nothing -> do + branch <- Git.currentBranch top + hPutStrLn stderr $ "packdiff: current branch: " ++ branch + writeIORef (envOriginalBranch env) (Just (top, branch)) + Git.checkout top sha + +-- | Check out the original branch again. The checkout is not forced; if it +-- fails, the branch is printed and an 'ObtainError' is thrown. +restoreInPlace :: Env -> IO () +restoreInPlace env = do + orig <- readIORef (envOriginalBranch env) + case orig of + Nothing -> pure () + Just (top, branch) -> do + r <- try (Git.checkout top branch) + case r of + Right () -> writeIORef (envOriginalBranch env) Nothing + Left (e :: PackDiffError) -> + throwIO $ ObtainError $ + "could not check out the original branch " ++ branch + ++ ": " ++ show e + +-------------------------------------------------------------------------------- +-- Obtaining +-------------------------------------------------------------------------------- + +data Obtained = Obtained + { obFile :: FilePath + , obHoogle :: Hoogle + } + +readObtained :: FilePath -> IO Obtained +readObtained path = Obtained path <$> readHoogleFile (Path.fromString_ path) + +-- | Look the hoogle file up in the cache, or build it and store it. +withCache :: Env -> String -> String -> IO FilePath -> IO Obtained +withCache env what rev build + | ecNoCache (envConfig env) = build >>= readObtained + | otherwise = do + (ghcV, haddockV) <- toolVersions env + let key = + CacheKey + { ckPackage = what + , ckRevision = rev + , ckGhcVersion = ghcV + , ckHaddockVersion = haddockV + , ckCabalOptions = bcCabalOptions (ecBuild (envConfig env)) + } + hit <- cacheLookup key + case hit of + Just path -> do + hPutStrLn stderr $ "packdiff: using cached " ++ path + readObtained path + Nothing -> build >>= cacheStore key >>= readObtained + +repoIdentity :: Env -> Repo -> IO String +repoIdentity env repo = + case repo of + RepoCurrent -> fst <$> currentRepo env + RepoLocal top -> pure top + RepoRemote url -> pure url + +-- | The work clone of a repository, created on first use. +workClone :: Env -> Repo -> IO FilePath +workClone env repo = do + ident <- repoIdentity env repo + clones <- readIORef (envClones env) + case Map.lookup ident clones of + Just dir -> pure dir + Nothing -> do + dir <- newWorkDir (envWorkSpace env) (hashHex ident) + let src = dir ++ "/src" + case repo of + RepoRemote _ -> Git.initRepo dir src + _ -> Git.cloneShared dir ident src + modifyIORef' (envClones env) (Map.insert ident dir) + pure dir + +resolveSha :: Env -> Repo -> String -> IO Sha +resolveSha env repo rev = + case repo of + RepoCurrent -> do + (top, _) <- currentRepo env + Git.resolveLocal top rev + RepoLocal top -> Git.resolveLocal top rev + RepoRemote url -> Git.resolveRemote (envCwd env) url rev + +-- | The directory to run cabal in, relative to the root of a ref: the root +-- with @--package@, otherwise the subdirectory corresponding to the current +-- directory for refs of the current repository. +subdirFor :: Env -> Repo -> IO FilePath +subdirFor env repo = + case (ecPackage (envConfig env), repo) of + (Nothing, RepoCurrent) -> snd <$> currentRepo env + _ -> pure "" + +-- | Append a relative directory, which may be empty, to a directory. +() :: FilePath -> FilePath -> FilePath +dir "" = dir +dir sub = dir ++ "/" ++ sub + +-- | The cache key part naming what was built. +cacheWhat :: Env -> FilePath -> String +cacheWhat env sub = + case ecPackage (envConfig env) of + Just pkg -> pkg + Nothing + | null sub -> "subdir-root" + | otherwise -> "subdir-" ++ sub + +obtainGit :: Env -> Repo -> String -> IO Obtained +obtainGit env repo rev = do + sha <- resolveSha env repo rev + sub <- subdirFor env repo + withCache env (cacheWhat env sub) sha (build sha sub) + + where + + cfg = envConfig env + bc = ecBuild cfg + pkg = ecPackage cfg + build sha sub + | ecInPlace cfg && repo == RepoCurrent = do + (top, _) <- currentRepo env + inPlaceCheckout env top sha + buildHoogle bc (top sub) pkg Nothing + | otherwise = do + wc <- workClone env repo + let src = wc ++ "/src" + case repo of + RepoRemote url -> Git.fetchSha src url sha + _ -> pure () + Git.checkout src sha + buildHoogle bc (src sub) pkg (Just (wc ++ "/build")) + +-- | The directory to build the working directory in: the current directory, +-- or with @--package@ the top level directory of the current repository. The +-- root of a project that is not in a git repository is the current directory. +projectRoot :: Env -> IO FilePath +projectRoot env = + case ecPackage (envConfig env) of + Nothing -> pure (envCwd env) + Just _ -> + (fst <$> currentRepo env) + `catches` + [ Handler (\(_ :: PackDiffError) -> pure (envCwd env)) + , Handler (\(_ :: IOException) -> pure (envCwd env)) + ] + +-- | The working directory, built in place. Not cached. +obtainCwd :: Env -> IO Obtained +obtainCwd env = do + dir <- projectRoot env + let cfg = envConfig env + buildHoogle (ecBuild cfg) dir (ecPackage cfg) Nothing >>= readObtained + +obtainHackage :: Env -> String -> HackageVersion -> IO Obtained +obtainHackage env pkg hv = do + ver <- + resolveHackageVersion pkg $ + case hv of + HackageLatest -> Nothing + HackageVersion v -> Just v + withCache env pkg ("hackage-" ++ ver) (build ver) + + where + + build ver = do + dir <- newWorkDir (envWorkSpace env) (pkg ++ "-" ++ ver) + src <- cabalGet dir pkg ver + buildHoogle + (ecBuild (envConfig env)) src (Just pkg) (Just (dir ++ "/build")) + +-- | Resolve a ref of the current repository to a commit SHA, and @.@ to the +-- SHA of @HEAD@ in in-place mode. In-place mode moves @HEAD@, so all refs must +-- be pinned before the first checkout. +pinRef :: Env -> Repo -> Ref -> IO Ref +pinRef env repo ref = + case (ref, repo) of + (RefGit rev, RepoCurrent) -> RefGit <$> resolveSha env RepoCurrent rev + (RefCwd, _) + | ecInPlace (envConfig env) -> + RefGit <$> resolveSha env RepoCurrent "HEAD" + _ -> pure ref + +-- | Obtain the hoogle file of a ref. The repository is used for git refs, the +-- package name for Hackage refs. +obtain :: Env -> Repo -> Maybe String -> Ref -> IO Obtained +obtain env repo hackagePkg ref = + case ref of + RefFile path -> readObtained path + RefCwd + | ecInPlace (envConfig env) -> obtainGit env RepoCurrent "HEAD" + | otherwise -> obtainCwd env + RefGit rev -> obtainGit env repo rev + RefHackage hv -> + case hackagePkg of + Just pkg -> obtainHackage env pkg hv + Nothing -> + usageError "a Hackage ref needs the package name (--package)" diff --git a/src/PackDiff/Options.hs b/src/PackDiff/Options.hs new file mode 100644 index 0000000..f1fd95f --- /dev/null +++ b/src/PackDiff/Options.hs @@ -0,0 +1,375 @@ +-- | +-- Module : PackDiff.Options +-- Copyright : (c) 2022 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- Command line options. + +module PackDiff.Options + ( Command (..) + , ColorMode (..) + , Format (..) + , Options (..) + , parserInfo + , parseOptions + , parseOptionsPure + ) where + +import Data.Set (Set) +import Options.Applicative +import Options.Applicative.Help.Pretty (vsep, pretty) +import System.Environment (getArgs, getProgName) +import System.Exit (ExitCode(..), exitWith) +import System.IO (hPutStrLn, stderr) + +import qualified Data.Set as Set + +import PackDiff.Diff (Change) +import PackDiff.Filter (Glob, parseChangeTypes, parseFailOn) +import PackDiff.Pretty (GroupBy(..)) + +-------------------------------------------------------------------------------- +-- Types +-------------------------------------------------------------------------------- + +data Command + = CmdDiff + | CmdCheck + | CmdApi + deriving (Eq, Show) + +data ColorMode + = ColorAuto + | ColorAlways + | ColorNever + deriving (Eq, Show) + +data Format + = FormatText + | FormatHoogle + deriving (Eq, Show) + +data Options = Options + { optCommand :: Command + , optRefs :: [String] + -- Refs + , optRepo :: Maybe String + , optOldRepo :: Maybe String + , optNewRepo :: Maybe String + , optPackage :: Maybe String + -- Output + , optColor :: ColorMode + , optGroupBy :: GroupBy + , optQuiet :: Bool + , optModulesOnly :: Bool + , optFormat :: Format + -- Filtering + , optShow :: Maybe (Set Change) + , optHide :: Maybe (Set Change) + , optBreakingOnly :: Bool + , optModules :: [Glob] + , optIgnoreModules :: [Glob] + , optInternalModules :: [Glob] + , optFailOn :: Maybe (Set Change) + -- Build + , optCompiler :: Maybe String + , optCabalOptions :: [String] + , optNoCache :: Bool + , optWorkDir :: Maybe FilePath + , optInPlace :: Bool + } + +-------------------------------------------------------------------------------- +-- Option groups +-------------------------------------------------------------------------------- + +-- | A repeatable option whose values are comma separated change type sets. +changeSets :: + (String -> Either String (Set Change)) -> Mod OptionFields (Set Change) + -> Parser (Maybe (Set Change)) +changeSets parse m = + fmap combine (many (option (eitherReader parse) m)) + + where + + combine [] = Nothing + combine xs = Just (Set.unions xs) + +data RepoOpts = RepoOpts (Maybe String) (Maybe String) (Maybe String) + +repoOpt :: Parser (Maybe String) +repoOpt = + optional $ strOption $ + long "repo" <> metavar "PATH-OR-URL" + <> help "Repository for git refs. Default: the repository of the \ + \current directory." + +oldNewRepoOpts :: Parser (Maybe String, Maybe String) +oldNewRepoOpts = + (,) + <$> optional (strOption $ + long "old-repo" <> metavar "PATH-OR-URL" + <> help "Repository for REF1 only.") + <*> optional (strOption $ + long "new-repo" <> metavar "PATH-OR-URL" + <> help "Repository for REF2 only.") + +packageOpt :: Parser (Maybe String) +packageOpt = + optional $ strOption $ + short 'p' <> long "package" <> metavar "NAME" + <> help "Package to compare, for repositories with several packages." + +data ModuleOpts = ModuleOpts [Glob] [Glob] [Glob] + +moduleOpts :: Parser ModuleOpts +moduleOpts = + ModuleOpts + <$> many (strOption $ + long "module" <> metavar "GLOB" + <> help "Only modules matching the glob. Repeatable.") + <*> many (strOption $ + long "ignore-module" <> metavar "GLOB" + <> help "Exclude modules matching the glob. Repeatable.") + <*> many (strOption $ + long "internal-module" <> metavar "GLOB" + <> help "Treat matching modules as internal. Repeatable. \ + \Default: *.Internal.* and *.Internal.") + +data BuildOpts = BuildOpts (Maybe String) [String] Bool (Maybe FilePath) Bool + +buildOpts :: Parser BuildOpts +buildOpts = + BuildOpts + <$> optional (strOption $ + short 'w' <> long "with-compiler" <> metavar "GHC" + <> help "Compiler used to build each ref.") + <*> many (strOption $ + long "cabal-option" <> metavar "OPT" + <> help "Extra option for cabal haddock, for every ref \ + \that is built. Repeatable.") + <*> switch (long "no-cache" + <> help "Do not read or write the hoogle file cache.") + <*> optional (strOption $ + long "work-dir" <> metavar "PATH" + <> help "Directory for work clones and unpacked Hackage \ + \sources. Default: $XDG_CACHE_HOME/packdiff/work.") + <*> switch (long "in-place" + <> help "Build git refs of the current repository by checking \ + \them out in the current working tree.") + +data OutputOpts = + OutputOpts ColorMode GroupBy Bool Bool + (Maybe (Set Change)) (Maybe (Set Change)) Bool + +colorReader :: ReadM ColorMode +colorReader = eitherReader $ \s -> + case s of + "auto" -> Right ColorAuto + "always" -> Right ColorAlways + "never" -> Right ColorNever + _ -> Left "expected auto, always or never" + +groupByReader :: ReadM GroupBy +groupByReader = eitherReader $ \s -> + case s of + "module" -> Right GroupByModule + "change" -> Right GroupByChange + _ -> Left "expected module or change" + +colorOpt :: Parser ColorMode +colorOpt = + option colorReader $ + long "color" <> metavar "MODE" <> value ColorAuto + <> help "auto (default), always or never. auto disables color \ + \when NO_COLOR is set or stdout is not a terminal." + +outputOpts :: Parser OutputOpts +outputOpts = + OutputOpts + <$> colorOpt + <*> option groupByReader + (long "group-by" <> metavar "G" <> value GroupByModule + <> help "module (default) or change.") + <*> switch (short 'q' <> long "quiet" <> help "Print only the summary.") + <*> switch (long "modules-only" + <> help "Print only the module lines and the summary.") + <*> changeSets parseChangeTypes + (long "show" <> metavar "TYPES" + <> help "Show only these change types: added, removed, \ + \changed, deprecated, undeprecated.") + <*> changeSets parseChangeTypes + (long "hide" <> metavar "TYPES" <> help "Hide these change types.") + <*> switch (long "breaking-only" + <> help "Shorthand for --show removed,changed.") + +failOnOpt :: Parser (Maybe (Set Change)) +failOnOpt = + changeSets parseFailOn + (long "fail-on" <> metavar "TYPES" + <> help "Exit with 1 if the diff contains a change of these types. \ + \Same values as --show, plus breaking and any.") + +formatOpt :: Parser Format +formatOpt = + option reader $ + long "format" <> metavar "FMT" <> value FormatText + <> help "text (default) or hoogle." + + where + + reader = eitherReader $ \s -> + case s of + "text" -> Right FormatText + "hoogle" -> Right FormatHoogle + _ -> Left "expected text or hoogle" + +refsArg :: String -> Parser [String] +refsArg meta = many (strArgument (metavar meta)) + +-------------------------------------------------------------------------------- +-- Commands +-------------------------------------------------------------------------------- + +mkOptions :: + Command + -> [String] + -> RepoOpts + -> Maybe String + -> ModuleOpts + -> BuildOpts + -> OutputOpts + -> Maybe (Set Change) + -> Format + -> Options +mkOptions cmd refs (RepoOpts repo old new) pkg + (ModuleOpts mods ignores internals) + (BuildOpts compiler cabalOpts noCache workDir inPlace) + (OutputOpts color groupBy quiet modsOnly shw hide breakingOnly) + failOn fmt = + Options + { optCommand = cmd + , optRefs = refs + , optRepo = repo + , optOldRepo = old + , optNewRepo = new + , optPackage = pkg + , optColor = color + , optGroupBy = groupBy + , optQuiet = quiet + , optModulesOnly = modsOnly + , optFormat = fmt + , optShow = shw + , optHide = hide + , optBreakingOnly = breakingOnly + , optModules = mods + , optIgnoreModules = ignores + , optInternalModules = internals + , optFailOn = failOn + , optCompiler = compiler + , optCabalOptions = cabalOpts + , optNoCache = noCache + , optWorkDir = workDir + , optInPlace = inPlace + } + +defaultOutputOpts :: ColorMode -> OutputOpts +defaultOutputOpts color = + OutputOpts color GroupByModule False False Nothing Nothing False + +diffParser :: Parser Options +diffParser = + (\refs repo (old, new) -> mkOptions CmdDiff refs (RepoOpts repo old new)) + <$> refsArg "[REF1 [REF2]]" + <*> repoOpt + <*> oldNewRepoOpts + <*> packageOpt + <*> moduleOpts + <*> buildOpts + <*> outputOpts + <*> failOnOpt + <*> pure FormatText + +checkParser :: Parser Options +checkParser = + (\refs repo (old, new) pkg mods bld -> + mkOptions CmdCheck refs (RepoOpts repo old new) pkg mods bld + (defaultOutputOpts ColorNever) Nothing FormatText) + <$> refsArg "[REF1 [REF2]]" + <*> repoOpt + <*> oldNewRepoOpts + <*> packageOpt + <*> moduleOpts + <*> buildOpts + +apiParser :: Parser Options +apiParser = + (\refs repo pkg mods bld color fmt -> + mkOptions CmdApi refs (RepoOpts repo Nothing Nothing) pkg mods bld + (defaultOutputOpts color) Nothing fmt) + <$> refsArg "[REF]" + <*> repoOpt + <*> packageOpt + <*> moduleOpts + <*> buildOpts + <*> colorOpt + <*> formatOpt + +usageFooter :: InfoMod a +usageFooter = + footerDoc $ Just $ vsep $ map pretty + [ "Refs: or git: (git revision), . (working directory)," + , "hackage:, hackage or hackage:latest, file: (hoogle file)." + , "" + , "Sigils: [+] added, [-] removed, [~] changed, [D] deprecated," + , "[U] undeprecated. Below a [~] entity, - is the old definition and" + , "+ is the new one." + , "" + , "Exit codes: 0 success, 1 --fail-on threshold reached or check found" + , "the declared version insufficient, 2 usage error, 3 failure to" + , "obtain an API." + ] + +commandParser :: Parser Options +commandParser = + hsubparser $ + command "diff" + (info diffParser + (progDesc "Print the API diff between two refs." <> usageFooter)) + <> command "check" + (info checkParser + (progDesc "Print the version bump required by the diff." <> usageFooter)) + <> command "api" + (info apiParser (progDesc "Print the API of a single ref." <> usageFooter)) + +parserInfo :: ParserInfo Options +parserInfo = + info (commandParser <**> helper) $ + fullDesc + <> progDesc "Find API changes between versions of a Haskell package." + <> usageFooter + +-- | Parse arguments without any IO. A failure carries the message and the +-- exit code: 0 for --help, 2 for a usage error. +parseOptionsPure :: String -> [String] -> Either (String, ExitCode) Options +parseOptionsPure prog args = + case execParserPure defaultPrefs parserInfo args of + Success opts -> Right opts + Failure f -> + let (msg, code) = renderFailure f prog + in Left (msg, if code == ExitSuccess then code else ExitFailure 2) + CompletionInvoked _ -> Left ("", ExitSuccess) + +-- | Parse the command line, exiting on --help or a usage error. +parseOptions :: IO Options +parseOptions = do + prog <- getProgName + args <- getArgs + case execParserPure defaultPrefs parserInfo args of + Failure f + | (msg, ExitFailure _) <- renderFailure f prog -> + hPutStrLn stderr msg >> exitWith (ExitFailure 2) + r -> handleParseResult r diff --git a/src/PackDiff/Pretty.hs b/src/PackDiff/Pretty.hs new file mode 100644 index 0000000..c3d0024 --- /dev/null +++ b/src/PackDiff/Pretty.hs @@ -0,0 +1,455 @@ +-- | +-- Module : PackDiff.Pretty +-- Copyright : (c) 2022 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- Rendering of API diffs and APIs as text. + +module PackDiff.Pretty + ( -- * Lines + Style (..) + , Seg (..) + , Line (..) + , renderLines + + -- * Diff + , GroupBy (..) + , RenderOptions (..) + , defaultRenderOptions + , renderDiff + , summaryLines + + -- * API + , renderAPI + + -- * Helpers + , highlightPair + ) where + +import Data.Char (isAlphaNum, isSpace, toUpper) +import Data.List (intercalate, isPrefixOf) +import Data.Map (Map) +import System.Console.ANSI + ( Color(..) + , ColorIntensity(..) + , ConsoleLayer(..) + , SGR(..) + , setSGRCode + ) + +import qualified Data.Map.Strict as Map + +import PackDiff.API +import PackDiff.Classify (breakingCount) +import PackDiff.Diff + +-------------------------------------------------------------------------------- +-- Lines +-------------------------------------------------------------------------------- + +data Style + = StyleAdded + | StyleRemoved + | StyleChanged + | StyleDeprecated + | StylePlain + deriving (Eq, Show) + +-- | A part of a line. Highlighted parts are the differing parts of a pair of +-- @-@ and @+@ lines. +data Seg + = Plain String + | Highlight String + deriving (Eq, Show) + +data Line = Line + { lineLevel :: Int -- ^ nesting level, 4 spaces each + , lineStyle :: Style + , lineSegs :: [Seg] + } deriving (Eq, Show) + +blank :: Line +blank = Line 0 StylePlain [] + +plainLine :: Int -> Style -> String -> Line +plainLine lvl st s = Line lvl st [Plain s] + +styleSGR :: Style -> [SGR] +styleSGR st = + case st of + StyleAdded -> [SetColor Foreground Dull Green] + StyleRemoved -> [SetColor Foreground Dull Red] + StyleChanged -> [SetColor Foreground Dull Yellow] + StyleDeprecated -> [SetColor Foreground Dull Magenta] + StylePlain -> [] + +renderLine :: Bool -> Line -> String +renderLine color (Line lvl st segs) = + replicate (4 * lvl) ' ' ++ body + + where + + sgr = styleSGR st + seg (Plain s) = s + seg (Highlight s) + | color = setSGRCode [SetSwapForegroundBackground True] ++ s + ++ setSGRCode [SetSwapForegroundBackground False] + | otherwise = s + text = concatMap seg segs + body + | color && not (null sgr) && not (null text) = + setSGRCode sgr ++ text ++ setSGRCode [Reset] + | otherwise = text + +-- | Render lines, with ANSI colors if the first argument is True. +renderLines :: Bool -> [Line] -> String +renderLines color = unlines . map (renderLine color) + +-------------------------------------------------------------------------------- +-- Changes +-------------------------------------------------------------------------------- + +sigil :: Change -> String +sigil c = + case c of + Added -> "[+]" + Removed -> "[-]" + Changed -> "[~]" + Deprecated -> "[D]" + Undeprecated -> "[U]" + +changeStyle :: Change -> Style +changeStyle c = + case c of + Added -> StyleAdded + Removed -> StyleRemoved + Changed -> StyleChanged + Deprecated -> StyleDeprecated + Undeprecated -> StyleDeprecated + +changeName :: Change -> String +changeName c = + case c of + Added -> "added" + Removed -> "removed" + Changed -> "changed" + Deprecated -> "deprecated" + Undeprecated -> "undeprecated" + +sigilLine :: Int -> Change -> String -> Line +sigilLine lvl c s = plainLine lvl (changeStyle c) (sigil c ++ " " ++ s) + +-------------------------------------------------------------------------------- +-- Highlighting +-------------------------------------------------------------------------------- + +-- | Identifiers, runs of spaces and single other characters. +tokens :: String -> [String] +tokens [] = [] +tokens s@(c : cs) + | isIdent c = let (a, b) = span isIdent s in a : tokens b + | isSpace c = let (a, b) = span isSpace s in a : tokens b + | otherwise = [c] : tokens cs + + where + + isIdent x = isAlphaNum x || x == '_' || x == '\'' + +-- XXX Use streamly-core's dropCommonPrefixBy when it is available in a +-- release (see dev/upstream-fixes.md). +dropCommonPrefix :: Eq a => [a] -> [a] -> ([a], [a], [a]) +dropCommonPrefix (x : xs) (y : ys) + | x == y = let (p, a, b) = dropCommonPrefix xs ys in (x : p, a, b) +dropCommonPrefix xs ys = ([], xs, ys) + +-- | Split each line of a pair into the common prefix, the differing middle +-- and the common suffix, at token boundaries. +highlightPair :: String -> String -> ([Seg], [Seg]) +highlightPair old new = (segs midOld, segs midNew) + + where + + (prefix, restOld, restNew) = dropCommonPrefix (tokens old) (tokens new) + (rsuffix, rmidOld, rmidNew) = + dropCommonPrefix (reverse restOld) (reverse restNew) + suffix = reverse rsuffix + midOld = reverse rmidOld + midNew = reverse rmidNew + segs mid = + filter nonEmpty + [Plain (concat prefix), Highlight (concat mid), Plain (concat suffix)] + nonEmpty (Plain s) = not (null s) + nonEmpty (Highlight s) = not (null s) + +-- | The @-@ and @+@ lines of a changed definition. +definitionPair :: Int -> String -> String -> [Line] +definitionPair lvl old new = + [ Line lvl StyleRemoved (Plain "- " : o) + , Line lvl StyleAdded (Plain "+ " : n) + ] + + where + + (o, n) = highlightPair old new + +-------------------------------------------------------------------------------- +-- Entity lines +-------------------------------------------------------------------------------- + +-- | Adds the module name to an entity line, used when the output is grouped +-- by change. +type Qualify = Decl -> String -> String + +-- | The text of a @[~]@ line: the name of a function, pattern or fixity, the +-- declaration head of a data type, newtype or class. +declLabel :: Decl -> String +declLabel d = + case declKind d of + KData -> declText d + KClass -> declText d + KTypeSyn -> takeBefore " = " (declText d) + KInstance -> declText d + KPattern -> declName d + KFunction -> declName d + KFixity -> declName d + + where + + takeBefore sep str@(c : cs) + | sep `isPrefixOf` str = [] + | otherwise = c : takeBefore sep cs + takeBefore _ [] = [] + +childLines :: Int -> ChildDiff -> [Line] +childLines lvl cd = + case (cdChange cd, cdOld cd, cdNew cd) of + (Changed, Just o, Just n) -> + sigilLine lvl Changed (childName n) + : definitionPair (lvl + 1) (childText o) (childText n) + (c, _, Just n) -> [sigilLine lvl c (childText n)] + (c, Just o, Nothing) -> [sigilLine lvl c (childText o)] + (_, Nothing, Nothing) -> [] + +-- | Lines of a declaration and its visible children. Empty if neither the +-- declaration nor any child is visible. +declLines :: (Change -> Bool) -> Qualify -> Int -> DeclDiff -> [Line] +declLines visible qual lvl dd + | visible (ddChange dd) || not (null children) = self ++ children + | otherwise = [] + + where + + d = declDiffDecl dd + children = + concatMap (childLines (lvl + 1)) + $ filter (visible . cdChange) (ddChildren dd) + self = + case (ddChange dd, ddOld dd, ddNew dd) of + (Changed, Just o, Just n) -> + sigilLine lvl Changed (qual n (declLabel n)) + : if declText o /= declText n + then definitionPair (lvl + 1) (declText o) (declText n) + else [] + (c, _, _) -> [sigilLine lvl c (qual d (declText d))] + +symbols :: Int -> String +symbols 1 = "(1 symbol)" +symbols n = "(" ++ show n ++ " symbols)" + +-- | The module line. Added and removed modules show their size. +moduleLine :: Int -> ModuleName -> ModuleDiff -> Line +moduleLine lvl name md = + case mdChange md of + c | c `elem` [Added, Removed] -> + sigilLine lvl c + (name ++ " " ++ symbols (moduleSize (moduleDiffModule md))) + c -> sigilLine lvl c name + +-------------------------------------------------------------------------------- +-- Diff +-------------------------------------------------------------------------------- + +data GroupBy + = GroupByModule + | GroupByChange + deriving (Eq, Show) + +data RenderOptions = RenderOptions + { roGroupBy :: GroupBy + , roQuiet :: Bool + , roModulesOnly :: Bool + , roVisible :: Change -> Bool + } + +defaultRenderOptions :: RenderOptions +defaultRenderOptions = + RenderOptions + { roGroupBy = GroupByModule + , roQuiet = False + , roModulesOnly = False + , roVisible = const True + } + +-- | Lines of one module in the output grouped by module. +moduleLines :: RenderOptions -> ModuleName -> ModuleDiff -> [Line] +moduleLines ro name md = + case mdChange md of + c | c `elem` [Added, Removed] -> + [moduleLine 0 name md | visible c] + c | visible c && c /= Changed || not (null decls) -> + moduleLine 0 name md : if roModulesOnly ro then [] else decls + _ -> [] + + where + + visible = roVisible ro + decls = concatMap (declLines visible (\_ s -> s) 1) (mdDecls md) + +groupedByModule :: RenderOptions -> APIDiff -> [Line] +groupedByModule ro = concatMap (uncurry (moduleLines ro)) . Map.toList + +-- | Qualify the name of an entity with its module name. +qualifyWith :: ModuleName -> Qualify +qualifyWith m d s = + case declKind d of + KInstance -> m ++ ": " ++ s + _ -> replaceFirstWord (declName d) s + + where + + qualified name = + case name of + ('(' : op) -> "(" ++ m ++ "." ++ op + _ -> m ++ "." ++ name + replaceFirstWord name str = + case break (== name) (splitKeep str) of + (before, _ : after) -> concat before ++ qualified name ++ concat after + (_, []) -> m ++ ": " ++ str + -- words with the spaces kept as separate elements + splitKeep [] = [] + splitKeep str@(c : _) + | isSpace c = let (a, b) = span isSpace str in a : splitKeep b + | otherwise = let (a, b) = break isSpace str in a : splitKeep b + +groupedByChange :: RenderOptions -> APIDiff -> [Line] +groupedByChange ro diff = + intercalate [blank] (filter (not . null) (map section [minBound .. maxBound])) + + where + + visible = roVisible ro + mods = Map.toList diff + section c + | null items = [] + | otherwise = plainLine 0 StylePlain (capitalize (changeName c) ++ ":") : items + + where + + modItems = + [ moduleLine 0 name md + | visible c, c /= Changed, (name, md) <- mods, mdChange md == c + ] + declItems = + [ l + | not (roModulesOnly ro) + , (name, md) <- mods + , dd <- mdDecls md + , ddChange dd == c + , l <- declLines visible (qualifyWith name) 0 dd + ] + items = modItems ++ declItems + capitalize (x : xs) = toUpper x : xs + capitalize [] = [] + +countLine :: String -> [Change] -> [String] +countLine label cs + | null parts = [] + | otherwise = [label ++ ": " ++ intercalate ", " parts] + + where + + order = [Added, Removed, Changed, Deprecated, Undeprecated] + count c = length (filter (== c) cs) + parts = + [ show (count c) ++ " " ++ changeName c ++ " " ++ sigil c + | c <- order + , count c > 0 + ] + +-- | The summary of a diff of released and internal modules. +summaryLines :: APIDiff -> APIDiff -> [String] +summaryLines released internal + | Map.null released && Map.null internal = ["No API changes."] + | otherwise = + countLine "Modules" (map mdChange rel) + ++ countLine "Symbols" symbolChanges + ++ countLine "Internal modules" (map mdChange (Map.elems internal)) + ++ [ "Breaking changes: " ++ show breaking | breaking > 0 ] + + where + + rel = Map.elems released + breaking = breakingCount rel + symbolChanges = + [ ch + | md <- rel + , mdChange md `notElem` [Added, Removed] + , dd <- mdDecls md + , ch <- ddChange dd : map cdChange (ddChildren dd) + ] + +-- | Render the diff of released and internal modules followed by the summary. +renderDiff :: RenderOptions -> APIDiff -> APIDiff -> [Line] +renderDiff ro released internal = + body ++ [blank | not (null body)] ++ summary + + where + + summary = map (plainLine 0 StylePlain) (summaryLines released internal) + group = + case roGroupBy ro of + GroupByModule -> groupedByModule ro + GroupByChange -> groupedByChange ro + rel = group released + int = group internal + internalSection + | null int = [] + | otherwise = + [blank | not (null rel)] + ++ plainLine 0 StylePlain "Internal modules:" : int + body + | roQuiet ro = [] + | otherwise = rel ++ internalSection + +-------------------------------------------------------------------------------- +-- API +-------------------------------------------------------------------------------- + +apiModuleLines :: ModuleName -> Module -> [Line] +apiModuleLines name m = + sigilLine 0 Added name : concatMap decl (Map.elems (moduleDecls m)) + + where + + decl d = + sigilLine 1 Added (declText d) + : map (sigilLine 2 Added . childText) (declChildren d) + +-- | The API of released and internal modules in the tree format, with every +-- entity marked @[+]@. +renderAPI :: Map ModuleName Module -> Map ModuleName Module -> [Line] +renderAPI released internal = rel ++ internalSection + + where + + linesOf = concatMap (uncurry apiModuleLines) . Map.toList + rel = linesOf released + int = linesOf internal + internalSection + | null int = [] + | otherwise = + [blank | not (null rel)] + ++ plainLine 0 StylePlain "Internal modules:" : int diff --git a/src/PackDiff/Process.hs b/src/PackDiff/Process.hs new file mode 100644 index 0000000..ac42049 --- /dev/null +++ b/src/PackDiff/Process.hs @@ -0,0 +1,109 @@ +-- | +-- Module : PackDiff.Process +-- Copyright : (c) 2022 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- Running external programs (@git@, @cabal@, @ghc@). +-- +-- The standard output of packdiff carries the diff, so the output of the +-- programs that is shown to the user goes to the standard error. +-- +-- Ctrl-C is delivered to the child process only ('interruptChildOnly'); the +-- process library raises 'UserInterrupt' in packdiff after the child has +-- exited. This way packdiff waits for the child before cleaning up, e.g. +-- before restoring a branch while an interrupted @git checkout@ still holds +-- @.git/index.lock@. + +module PackDiff.Process + ( Cmd (..) + , showCmd + , readCmd + , readCmdLines + , runCmd + ) where + +import Control.Exception (catch, throwIO) +import Data.Function ((&)) +import Data.Word (Word8) +import Streamly.Data.Array (Array) +import Streamly.Data.Stream (Stream) +import Streamly.Internal.System.Process (ProcessFailure(..)) +import System.IO (hFlush, hPutStrLn, stderr) + +import qualified Streamly.Data.Fold as Fold +import qualified Streamly.Data.Stream as Stream +import qualified Streamly.FileSystem.Handle as Handle +import qualified Streamly.Internal.System.Process as Process +import qualified Streamly.Unicode.Stream as Unicode + +import PackDiff.Error (PackDiffError(..)) + +-- | A program, its arguments and the directory to run it in. +data Cmd = Cmd + { cmdDir :: Maybe FilePath + , cmdProgram :: String + , cmdArgs :: [String] + } deriving (Show) + +-- | The command line, for messages. +showCmd :: Cmd -> String +showCmd c = unwords (map quote (cmdProgram c : cmdArgs c)) ++ dir + + where + + quote s + | null s || any (`elem` " \"'") s = show s + | otherwise = s + dir = maybe "" (\d -> " (in " ++ d ++ ")") (cmdDir c) + +-- XXX The process stream of streamly-process does not wait for the child to +-- exit when the stream is aborted by an exception other than an interrupt +-- delivered to the child, e.g. SIGTERM: the child is sent SIGTERM and reaped +-- asynchronously. The cleanup may then run while the child is still running +-- (see dev/upstream-fixes.md). +stdoutChunks :: Cmd -> Stream IO (Array Word8) +stdoutChunks c = + Process.toChunksWith + (Process.setCwd (cmdDir c) . Process.interruptChildOnly True) + (cmdProgram c) + (cmdArgs c) + +-- | Turn a process failure into an 'ObtainError' naming the command. +-- +-- XXX ProcessFailure carries only the exit code (see dev/upstream-fixes.md). +withFailure :: Cmd -> IO a -> IO a +withFailure c action = action `catch` handler + + where + + handler (ProcessFailure code) = + throwIO $ ObtainError $ + "command failed with exit code " ++ show code ++ ": " ++ showCmd c + +-- | Run a command and return its standard output. Its standard error goes to +-- the standard error of packdiff. +readCmd :: Cmd -> IO String +readCmd c = + withFailure c + $ stdoutChunks c + & Unicode.decodeUtf8Chunks + & Stream.fold Fold.toList + +-- | 'readCmd' split into lines. +readCmdLines :: Cmd -> IO [String] +readCmdLines = fmap lines . readCmd + +-- | Run a command and copy its standard output to the standard error of +-- packdiff. The command line is printed first. Returns the standard output. +runCmd :: Cmd -> IO String +runCmd c = do + hPutStrLn stderr ("packdiff: " ++ showCmd c) + hFlush stderr + withFailure c + $ stdoutChunks c + & Stream.trace (Handle.putChunk stderr) + & Unicode.decodeUtf8Chunks + & Stream.fold Fold.toList diff --git a/src/PackDiff/Ref.hs b/src/PackDiff/Ref.hs new file mode 100644 index 0000000..2cb530e --- /dev/null +++ b/src/PackDiff/Ref.hs @@ -0,0 +1,108 @@ +-- | +-- Module : PackDiff.Ref +-- Copyright : (c) 2022 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- Refs given on the command line and the repositories of git refs. + +module PackDiff.Ref + ( -- * Refs + HackageVersion (..) + , Ref (..) + , parseRef + , isGitRef + , isHackageRef + + -- * Repositories + , Repo (..) + , classifyRepo + , isRemoteUrl + ) where + +import Data.List (isInfixOf) + +-------------------------------------------------------------------------------- +-- Refs +-------------------------------------------------------------------------------- + +data HackageVersion + = HackageLatest + | HackageVersion String + deriving (Eq, Show) + +data Ref + = RefGit String -- ^ a git revision + | RefCwd -- ^ the current working directory, @.@ + | RefHackage HackageVersion + | RefFile FilePath -- ^ a hoogle file + deriving (Eq, Show) + +-- | Parse a ref of the form @:@. A ref without a scope is a git +-- ref, except @.@ and @hackage@. +parseRef :: String -> Either String Ref +parseRef s = + case s of + "" -> Left "empty ref" + "." -> Right RefCwd + "hackage" -> Right (RefHackage HackageLatest) + _ -> + case break (== ':') s of + ("git", ':' : rev) -> gitRef rev + ("hackage", ':' : "latest") -> Right (RefHackage HackageLatest) + ("hackage", ':' : ver) + | null ver -> Left "empty version in ref: hackage:" + | otherwise -> Right (RefHackage (HackageVersion ver)) + ("file", ':' : path) + | null path -> Left "empty path in ref: file:" + | otherwise -> Right (RefFile path) + (scope, ':' : _) -> Left $ "unknown ref scope: " ++ scope + (rev, _) -> gitRef rev + + where + + gitRef rev + | null rev = Left "empty git revision" + | head rev == '-' = Left $ "invalid git revision: " ++ rev + | otherwise = Right (RefGit rev) + +isGitRef :: Ref -> Bool +isGitRef (RefGit _) = True +isGitRef _ = False + +isHackageRef :: Ref -> Bool +isHackageRef (RefHackage _) = True +isHackageRef _ = False + +-------------------------------------------------------------------------------- +-- Repositories +-------------------------------------------------------------------------------- + +-- | The repository of a git ref. +data Repo + = RepoCurrent -- ^ the repository of the current directory + | RepoLocal FilePath -- ^ absolute path of the top level directory + | RepoRemote String -- ^ URL + deriving (Eq, Ord, Show) + +-- | A URL, or the scp-like syntax @user\@host:path@ understood by git. +isRemoteUrl :: String -> Bool +isRemoteUrl s = "://" `isInfixOf` s || scpLike + + where + + scpLike = + case break (== ':') s of + (host, ':' : _) -> '@' `elem` host && '/' `notElem` host + _ -> False + +-- | Classify the value of a repository flag, given whether it names an +-- existing directory. A directory takes precedence over a URL. +classifyRepo :: Bool -> String -> Either String (Either FilePath String) +classifyRepo isDir s + | isDir = Right (Left s) + | isRemoteUrl s = Right (Right s) + | otherwise = + Left $ "repository is neither a directory nor a URL: " ++ s diff --git a/src/PackDiff/Signals.hs b/src/PackDiff/Signals.hs new file mode 100644 index 0000000..cf504ff --- /dev/null +++ b/src/PackDiff/Signals.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE CPP #-} +-- | +-- Module : PackDiff.Signals +-- Copyright : (c) 2022 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- The GHC runtime delivers SIGINT (Ctrl-C) as a 'UserInterrupt' exception, +-- but by default exits on SIGTERM and SIGHUP without running any cleanup. +-- The handlers installed here throw 'Terminated' to the main thread so that +-- the cleanup in 'Control.Exception.bracket' runs. +-- +-- XXX This is a general facility that belongs in streamly-coreutils (see +-- dev/upstream-fixes.md). + +module PackDiff.Signals + ( Terminated (..) + , installTerminationHandlers + ) where + +import Control.Concurrent (myThreadId, throwTo) +import Control.Exception (Exception) + +#if defined(mingw32_HOST_OS) +import Control.Exception (AsyncException(UserInterrupt)) +import qualified GHC.ConsoleHandler as Console +#else +import qualified System.Posix.Signals as Posix +#endif + +-- | The process received a termination signal, named by the string. +newtype Terminated = Terminated String + deriving Show + +instance Exception Terminated + +-- | Must be called from the main thread. +installTerminationHandlers :: IO () +#if defined(mingw32_HOST_OS) +installTerminationHandlers = do + tid <- myThreadId + let handler ev = + case ev of + -- Installing a handler replaces the default Ctrl-C handling. + Console.ControlC -> throwTo tid UserInterrupt + Console.Break -> throwTo tid (Terminated "Ctrl-Break") + Console.Close -> throwTo tid (Terminated "console closed") + Console.Logoff -> throwTo tid (Terminated "logoff") + Console.Shutdown -> throwTo tid (Terminated "shutdown") + _ <- Console.installHandler (Console.Catch handler) + pure () +#else +installTerminationHandlers = do + tid <- myThreadId + let install sig name = + Posix.installHandler sig + (Posix.Catch (throwTo tid (Terminated name))) Nothing + _ <- install Posix.sigTERM "SIGTERM" + _ <- install Posix.sigHUP "SIGHUP" + pure () +#endif diff --git a/src/PackDiff/WorkDir.hs b/src/PackDiff/WorkDir.hs new file mode 100644 index 0000000..a88d3b5 --- /dev/null +++ b/src/PackDiff/WorkDir.hs @@ -0,0 +1,173 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | +-- Module : PackDiff.WorkDir +-- Copyright : (c) 2022 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- The work directory holds work clones and unpacked Hackage sources. Each +-- directory created in it is named @-@ and deleted when the run +-- ends. A directory left behind by a killed run is deleted by the next run, +-- which finds that its process is no longer running. + +module PackDiff.WorkDir + ( WorkSpace + , defaultWorkRoot + , withWorkSpace + , newWorkDir + , currentPid + , isProcessAlive + , parsePidPrefix + , removeTree + ) where + +import Control.Concurrent (threadDelay) +import Control.Exception + (SomeException, bracket, displayException, try, uninterruptibleMask_) +import Control.Monad (forM_, unless, when) +import Data.Char (isDigit) +import Data.IORef (IORef, modifyIORef', newIORef, readIORef) +import System.Directory (XdgDirectory(..), doesPathExist, getXdgDirectory) +import System.IO (hPutStrLn, stderr) + +import qualified Coreutils.Mkdir as Mkdir +import qualified Coreutils.Rm as Rm +import qualified Streamly.Data.Fold as Fold +import qualified Streamly.Data.Stream as Stream +import qualified Streamly.FileSystem.DirIO as DirIO +import qualified Streamly.FileSystem.Path as Path + +#if defined(mingw32_HOST_OS) +import qualified System.Win32.File as Win32 +import qualified System.Win32.Process as Win32 +#else +import System.IO.Error (isPermissionError) +import qualified System.Posix.Process as Posix +import qualified System.Posix.Signals as Posix +#endif + +-------------------------------------------------------------------------------- +-- Processes +-------------------------------------------------------------------------------- + +currentPid :: IO Int +#if defined(mingw32_HOST_OS) +currentPid = fromIntegral <$> Win32.getCurrentProcessId +#else +currentPid = fromIntegral <$> Posix.getProcessID +#endif + +-- | Whether a process with this id is running. +-- +-- XXX This and 'currentPid' belong in streamly-coreutils (see +-- dev/upstream-fixes.md). +-- +-- XXX On Windows this is not tested. A process that has exited but whose +-- handle is still open somewhere is reported as running. +isProcessAlive :: Int -> IO Bool +#if defined(mingw32_HOST_OS) +isProcessAlive pid = do + r <- try (Win32.openProcess Win32.pROCESS_QUERY_INFORMATION False (fromIntegral pid)) + case r of + Left (_ :: SomeException) -> pure False + Right h -> Win32.closeHandle h >> pure True +#else +isProcessAlive pid = do + r <- try (Posix.signalProcess Posix.nullSignal (fromIntegral pid)) + case r of + Right () -> pure True + -- EPERM: the process exists but belongs to another user + Left e -> pure (isPermissionError e) +#endif + +-------------------------------------------------------------------------------- +-- Directories +-------------------------------------------------------------------------------- + +-- XXX coreutils functions take a streamly Path while the directory and +-- process packages take a FilePath, so paths are converted at each call. +toPath :: FilePath -> Path.Path +toPath = Path.fromString_ + +-- | Delete a directory tree if it exists. +-- +-- XXX A child process aborted by an exception may still be running and +-- writing into the tree, because streamly-process does not wait for it (see +-- dev/upstream-fixes.md), so the deletion is retried a few times. +removeTree :: FilePath -> IO () +removeTree dir = go (5 :: Int) + + where + + go n = do + r <- try (Rm.rm (Rm.recursive True . Rm.withForce Rm.Force) (toPath dir)) + case r of + Right () -> pure () + Left (e :: SomeException) + | n > 1 -> threadDelay 200000 >> go (n - 1) + | otherwise -> + hPutStrLn stderr $ + "packdiff: could not delete " ++ dir ++ ": " + ++ displayException e + +-- | The process id at the start of a work directory name, @-@. +parsePidPrefix :: String -> Maybe Int +parsePidPrefix name = + case span isDigit name of + (ds@(_ : _), '-' : _) -> Just (read ds) + _ -> Nothing + +data WorkSpace = WorkSpace + { wsRoot :: FilePath + , wsPid :: Int + , wsDirs :: IORef [FilePath] + } + +-- | @$XDG_CACHE_HOME/packdiff/work@ +defaultWorkRoot :: IO FilePath +defaultWorkRoot = fmap (++ "/work") (getXdgDirectory XdgCache "packdiff") + +-- | Delete the directories of runs that are no longer running. +removeStale :: FilePath -> Int -> IO () +removeStale root self = do + entries <- + Stream.fold Fold.toList (DirIO.read (toPath root)) + forM_ entries $ \entry -> do + let name = baseName (Path.toString entry) + case parsePidPrefix name of + Just pid | pid /= self -> do + alive <- isProcessAlive pid + unless alive $ removeTree (root ++ "/" ++ name) + _ -> pure () + + where + + baseName = reverse . takeWhile (\c -> c /= '/' && c /= '\\') . reverse + +-- | Run an action with a work space in the given root directory. Directories +-- created with 'newWorkDir' are deleted when the action ends, including on an +-- exception. +withWorkSpace :: FilePath -> (WorkSpace -> IO a) -> IO a +withWorkSpace root action = do + Mkdir.mkdir (Mkdir.makeParents True) (toPath root) + pid <- currentPid + removeStale root pid + ref <- newIORef [] + bracket + (pure (WorkSpace root pid ref)) + (\ws -> uninterruptibleMask_ $ readIORef (wsDirs ws) >>= mapM_ removeTree) + action + +-- | Create an empty directory @/-@ that is deleted when the +-- work space is released. +newWorkDir :: WorkSpace -> String -> IO FilePath +newWorkDir ws name = do + let dir = wsRoot ws ++ "/" ++ show (wsPid ws) ++ "-" ++ name + modifyIORef' (wsDirs ws) (dir :) + exists <- doesPathExist dir + when exists $ removeTree dir + Mkdir.mkdir (Mkdir.makeParents True) (toPath dir) + pure dir diff --git a/src/Pretty.hs b/src/Pretty.hs deleted file mode 100644 index dc90b7f..0000000 --- a/src/Pretty.hs +++ /dev/null @@ -1,207 +0,0 @@ --- | --- Module : Pretty --- Copyright : (c) 2022 Composewell Technologies --- License : BSD-3-Clause --- Maintainer : streamly@composewell.com --- Stability : released --- Portability : GHC - -module Pretty - ( prettyAPI - , prettyMC - , prettyD0 - , prettyD1 - , Element(..) - , printer - ) where - --------------------------------------------------------------------------------- --- Imports --------------------------------------------------------------------------------- - -import Data.List (intersperse, nub) -import Data.Map (Map) - -import qualified Data.Map.Strict as SMap - -import HoogleFileParser -import Diff - --------------------------------------------------------------------------------- --- Printing helpers --------------------------------------------------------------------------------- - -{- -prettyTag :: StatusTag s -> String -prettyTag Added = "[A]" -prettyTag Removed = "[R]" -prettyTag Same = "[S]" -prettyTag (Changed _) = "[C]" --} - -isDeprecated :: [Annotation] -> Bool -isDeprecated anns = - let f x = - case x of - Deprecated _ -> True - _ -> False - in not $ null $ filter f anns - --- Don't print if deprecated in Left --- Error out if deprecated in Left and not deprecated in Right --- Error out if deprecated in Right and Added -prettyD0_ :: - String - -> Tagged (Attach (Diff [Annotation]) (StatusTag EntityContextType)) EntityContextType - -> [String] -prettyD0_ _ (Tagged (Attach (DLeft anns) Removed) b) = - if isDeprecated anns - then [""] - else ["[R] " ++ showECT b] -prettyD0_ _ (Tagged (Attach (DRight anns) Added) b) = - if isDeprecated anns - then [""] - else ["[A] " ++ showECT b] -prettyD0_ k (Tagged (Attach (DBoth annsL annsR) (Changed b1)) b) = - if isDeprecated annsR && isDeprecated annsL - then [""] - else if isDeprecated annsR && not (isDeprecated annsL) - then ["[D] " ++ showECT b1] - else if not (isDeprecated annsR) && isDeprecated annsL - then [""] - else if b1 == b - then [""] - else concat - [ ["[C] " ++ k] - , indenter - 4 - ["[O] " ++ showECT b, "[N] " ++ showECT b1] - ] -prettyD0_ _ (Tagged (Attach (DBoth annsL annsR) Same) b) = - if isDeprecated annsR && not (isDeprecated annsL) - then ["[D] " ++ showECT b] - else [""] -prettyD0_ _ _ = error "prettyD0_: impossible pattern" - -prettyD1_ :: - String - -> Tagged (Attach (Diff [Annotation]) (StatusTag ())) (Map String (Tagged (Attach (Diff [Annotation]) (StatusTag EntityContextType)) EntityContextType)) - -> [String] -prettyD1_ k (Tagged (Attach (DLeft anns) Removed) _) = - if isDeprecated anns - then [""] - else ["[R] " ++ k] -prettyD1_ k (Tagged (Attach (DRight anns) Added) b) = - if isDeprecated anns - then [""] - else concat [["[A] " ++ k], indenter 4 (prettyD0 b)] -prettyD1_ k (Tagged (Attach (DBoth annsL annsR) (Changed ())) b) = - if isDeprecated annsR && isDeprecated annsL - then [""] - else if isDeprecated annsR && not (isDeprecated annsL) - then concat [["[D] " ++ k], indenter 4 (prettyD0 b)] - else if not (isDeprecated annsR) && isDeprecated annsL - then [""] - else concat [["[C] " ++ k], indenter 4 (prettyD0 b)] -prettyD1_ k (Tagged (Attach (DBoth annsL annsR) Same) _) = - if isDeprecated annsR && not (isDeprecated annsL) - then ["[D] " ++ k] - else [""] -prettyD1_ _ _ = error "prettyD1_: impossible pattern" - -prettyAPI_ :: - [Element] - -> ModuleName - -> Tagged (Attach (Diff [Annotation]) (StatusTag ())) (ModuleContextDefault (Attach (Diff [Annotation]) (StatusTag ())) (Attach (Diff [Annotation]) (StatusTag EntityContextType))) - -> [String] -prettyAPI_ _ k (Tagged (Attach (DLeft anns) Removed) _) = - if isDeprecated anns - then [""] - else ["[R] " ++ k] -prettyAPI_ elems k (Tagged (Attach (DRight anns) Added) b) = - if isDeprecated anns - then [""] - else concat [["[A] " ++ k], indenter 4 (prettyMC elems b)] -prettyAPI_ elems k (Tagged (Attach (DBoth annsL annsR) (Changed ())) b) = - if isDeprecated annsR && isDeprecated annsL - then [""] - else if isDeprecated annsR && not (isDeprecated annsL) - then concat [["[D] " ++ k], indenter 4 (prettyMC elems b)] - else if not (isDeprecated annsR) && isDeprecated annsL - then [""] - else concat [["[C] " ++ k], indenter 4 (prettyMC elems b)] -prettyAPI_ _ k (Tagged (Attach (DBoth annsL annsR) Same) _) = - if isDeprecated annsR && not (isDeprecated annsL) - then ["[D] " ++ k] - else [""] -prettyAPI_ _ _ _ = error "prettyAPI_: impossible pattern" - -indenter :: Int -> [String] -> [String] -indenter i = map (replicate i ' ' ++) - -printer :: [String] -> String -printer = concat . intersperse "\n" . filter (not . null . stripBegin) - -data Element - = ELClasses - | ELDataTypes Bool - | ELFixities - | ELInstances Bool - | ELNewTypes Bool - | ELPatterns - | ELTypeAliases - | ELFunctions - deriving (Eq) - -prettyD0 :: - Map String (Tagged (Attach (Diff [Annotation]) (StatusTag EntityContextType)) EntityContextType) - -> [String] -prettyD0 = SMap.foldlWithKey step initial - - where - - initial = [] - - step a k t = prettyD0_ k t ++ a - -prettyD1 :: - Bool - -> Map String (Tagged (Attach (Diff [Annotation]) (StatusTag ())) (Map String (Tagged (Attach (Diff [Annotation]) (StatusTag EntityContextType)) EntityContextType))) - -> [String] -prettyD1 _ = SMap.foldlWithKey step initial - - where - - initial = [] - - step a k t = prettyD1_ k t ++ a - -prettyMC :: - [Element] - -> ModuleContextDefault (Attach (Diff [Annotation]) (StatusTag ())) (Attach (Diff [Annotation]) (StatusTag EntityContextType)) - -> [String] -prettyMC elems ctx = concat $ map displayer $ nub elems - - where - - displayer ELClasses = prettyD0 $ mClasses ctx - displayer (ELDataTypes l) = prettyD1 l $ mDataTypes ctx - displayer ELFixities = prettyD0 $ mFixities ctx - displayer (ELInstances l) = prettyD1 l $ mInstances ctx - displayer (ELNewTypes l) = prettyD1 l $ mNewTypes ctx - displayer ELPatterns = prettyD0 $ mPatterns ctx - displayer ELTypeAliases = prettyD0 $ mTypeAliases ctx - displayer ELFunctions = prettyD0 $ mFunctions ctx - - -prettyAPI :: - [Element] - -> API (Attach (Diff [Annotation]) (StatusTag ())) (Attach (Diff [Annotation]) (StatusTag ())) (Attach (Diff [Annotation]) (StatusTag EntityContextType)) - -> String -prettyAPI elems = printer . SMap.foldlWithKey step initial - - where - - initial = [] - - step a k t = prettyAPI_ elems k t ++ a diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 index 0000000..ee6943d --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,367 @@ +-- | +-- Module : Main +-- Copyright : (c) 2022 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- The golden tests compare the output with the files in @test/golden@. Run +-- with @PACKDIFF_ACCEPT=1@ to write the current output to them instead. + +module Main (main) where + +import Data.Maybe (isJust) +import System.Environment (lookupEnv) +import System.Exit (ExitCode(..)) +import Test.Hspec + +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import qualified Streamly.FileSystem.Path as Path + +import PackDiff.API +import PackDiff.Cabal (hoogleFileFromOutput, latestVersion, parseVersionList) +import PackDiff.Cache (CacheKey(..), cacheFileName) +import PackDiff.Classify +import PackDiff.Diff +import PackDiff.Filter +import PackDiff.Git (matchRemoteRef) +import PackDiff.Hash (fnv1a64, hashHex) +import PackDiff.HoogleFileParser +import PackDiff.Main (defaultRefs) +import PackDiff.Options +import PackDiff.Pretty +import PackDiff.Ref +import PackDiff.WorkDir (parsePidPrefix) + +-------------------------------------------------------------------------------- +-- Helpers +-------------------------------------------------------------------------------- + +dataFile :: String -> FilePath +dataFile name = "test/data/" ++ name + +readHoogle :: String -> IO Hoogle +readHoogle = readHoogleFile . Path.fromString_ . dataFile + +-- | Parse a file given as a list of lines, failing the test on an error. +parseLines :: [String] -> Hoogle +parseLines = either error id . parseHoogleLines + +-- | Compare with a golden file, or write it when PACKDIFF_ACCEPT is set. +golden :: String -> String -> Expectation +golden name actual = do + let path = "test/golden/" ++ name ++ ".out" + accept <- lookupEnv "PACKDIFF_ACCEPT" + if isJust accept + then writeFile path actual + else do + expected <- readFile path + actual `shouldBe` expected + +internalFilter :: ModuleFilter +internalFilter = ModuleFilter [] [] defaultInternalGlobs + +-- | Diff the two test files, split into released and internal modules. +testDiff :: IO (APIDiff, APIDiff) +testDiff = do + old <- readHoogle "old.txt" + new <- readHoogle "new.txt" + pure $ partitionInternal internalFilter + $ diffAPI (hoogleAPI old) (hoogleAPI new) + +renderTestDiff :: RenderOptions -> IO String +renderTestDiff ro = do + (rel, int) <- testDiff + pure $ renderLines False (renderDiff ro rel int) + +declsOf :: ModuleName -> Hoogle -> [Decl] +declsOf m h = + maybe [] (Map.elems . moduleDecls) (Map.lookup m (hoogleAPI h)) + +-------------------------------------------------------------------------------- +-- Parser +-------------------------------------------------------------------------------- + +parserSpec :: Spec +parserSpec = describe "HoogleFileParser" $ do + it "reads @package and @version lines" $ do + h <- readHoogle "old.txt" + hooglePackages h `shouldBe` ["testpkg"] + hoogleVersions h `shouldBe` ["1.2.0.0"] + + it "groups constructors and fields under their data type" $ do + h <- readHoogle "old.txt" + let fold = [d | d <- declsOf "Test.Fold" h, declName d == "Fold"] + map (map childName . declChildren) fold + `shouldBe` [["Fold", "[foldStep]"]] + + it "joins a multi line class declaration and finds its methods" $ do + h <- readHoogle "old.txt" + let cls = [d | d <- declsOf "Test.Fold" h, declName d == "IsMap"] + map declText cls + `shouldBe` + [ "class IsMap (f :: Type -> Type) where { type Key (f :: \ + \Type -> Type); }" + ] + map (map childName . declChildren) cls + `shouldBe` [["mapEmpty", "mapInsert"]] + + it "takes the class name after the context" $ do + h <- readHoogle "old.txt" + [declName d | d <- declsOf "Test.Fold" h, declKind d == KClass] + `shouldBe` ["IsMap", "MonadAsync"] + + it "marks deprecated declarations and modules" $ do + h <- readHoogle "new.txt" + [declName d | d <- declsOf "Test.Prelude" h, declDeprecated d] + `shouldBe` ["parEval"] + fmap moduleDeprecated (Map.lookup "Test.ToBeDeprecated" (hoogleAPI h)) + `shouldBe` Just True + + it "parses fixities and operators" $ do + h <- readHoogle "old.txt" + [declName d | d <- declsOf "Test.Fold" h, declKind d == KFixity] + `shouldBe` ["<>"] + [declName d | d <- declsOf "Test.Fold" h, declName d == "(<>)"] + `shouldBe` ["(<>)"] + + it "skips a forall when matching class methods" $ do + let h = parseLines + [ "module M" + , "class C m" + , "f :: forall (m :: Type -> Type) a. C m => a -> m a" + , "g :: forall a. Show a => a" + ] + map (map childName . declChildren) (filter ((== KClass) . declKind) (declsOf "M" h)) + `shouldBe` [["f"]] + + it "rejects a declaration outside a module" $ + parseHoogleLines ["foo :: Int"] `shouldSatisfy` either (const True) (const False) + + it "parses a concatenation as the merge of the parts" $ do + a <- readFile (dataFile "pkga.txt") + b <- readFile (dataFile "pkgb.txt") + let ha = parseLines (lines a) + hb = parseLines (lines b) + hab = parseLines (lines (a ++ b)) + hoogleAPI hab + `shouldBe` mergeNonConflictingAPI (hoogleAPI ha) (hoogleAPI hb) + hooglePackages hab `shouldBe` ["pkga", "pkgb"] + hoogleVersions hab `shouldBe` ["0.1", "0.2"] + + it "replaces a repeated module with the later one" $ do + let h = parseLines ["module M", "a :: Int", "module M", "b :: Int"] + map declName (declsOf "M" h) `shouldBe` ["b"] + +-------------------------------------------------------------------------------- +-- Diff and classification +-------------------------------------------------------------------------------- + +diffSpec :: Spec +diffSpec = describe "Diff" $ do + it "classifies module changes" $ do + (rel, int) <- testDiff + Map.map mdChange rel + `shouldBe` Map.fromList + [ ("Test.Fold", Changed) + , ("Test.Prelude", Changed) + , ("Test.Scanl", Added) + , ("Test.ToBeDeprecated", Deprecated) + , ("Test.Unfold.Old", Removed) + ] + Map.keys int `shouldBe` ["Test.Internal.Fold"] + + it "counts breaking changes" $ do + (rel, _) <- testDiff + -- module removed; Step, Fold, IsMap, toHashMapIO, removedFn, + -- instance Show, fixity <> changed or removed + breakingCount (Map.elems rel) `shouldBe` 8 + + it "does not count a child deprecation as breaking" $ do + let child c d = Child c c d + decl cs = Decl KData "T" "data T" [] False cs + dd = DeclDiff Changed (Just (decl [child "A" False])) + (Just (decl [child "A" True])) + [ChildDiff Deprecated (Just (child "A" False)) (Just (child "A" True))] + isBreakingDecl dd `shouldBe` False + + it "requires bumps according to the PVP" $ do + (rel, _) <- testDiff + requiredBump (Map.elems rel) `shouldBe` BumpMajor + requiredBump [] `shouldBe` BumpPatch + bumpVersion BumpMajor [1, 2] `shouldBe` [1, 3, 0, 0] + bumpVersion BumpMinor [1, 2, 0, 0] `shouldBe` [1, 2, 1, 0] + bumpVersion BumpPatch [1, 2, 0, 0] `shouldBe` [1, 2, 0, 1] + + it "compares versions with missing components as zero" $ do + compareVersion [1, 2] [1, 2, 0, 0] `shouldBe` EQ + compareVersion [1, 2, 1] [1, 3, 0, 0] `shouldBe` LT + parseVersion "1.2.0.1" `shouldBe` Just [1, 2, 0, 1] + parseVersion "1.x" `shouldBe` Nothing + + it "evaluates --fail-on" $ do + (rel, int) <- testDiff + let failOn s = either error (`hasChangeIn` Map.elems rel) (parseFailOn s) + failOn "breaking" `shouldBe` True + failOn "undeprecated" `shouldBe` True + -- internal modules never count + either error (`hasChangeIn` Map.elems int) (parseFailOn "added") + `shouldBe` True + parseFailOn "bogus" `shouldSatisfy` either (const True) (const False) + +-------------------------------------------------------------------------------- +-- Rendering +-------------------------------------------------------------------------------- + +prettySpec :: Spec +prettySpec = describe "Pretty" $ do + it "renders the diff grouped by module" $ + renderTestDiff defaultRenderOptions >>= golden "diff" + + it "renders the diff grouped by change" $ + renderTestDiff defaultRenderOptions { roGroupBy = GroupByChange } + >>= golden "diff-group-by-change" + + it "renders only shown change types" $ + renderTestDiff defaultRenderOptions { roVisible = (== Added) } + >>= golden "diff-show-added" + + it "renders module lines only" $ + renderTestDiff defaultRenderOptions { roModulesOnly = True } + >>= golden "diff-modules-only" + + it "renders only the summary when quiet" $ + renderTestDiff defaultRenderOptions { roQuiet = True } + >>= golden "diff-quiet" + + it "renders an API" $ do + h <- readHoogle "new.txt" + let (rel, int) = partitionInternal internalFilter (hoogleAPI h) + golden "api" (renderLines False (renderAPI rel int)) + + it "renders an empty diff" $ + renderLines False (renderDiff defaultRenderOptions Map.empty Map.empty) + `shouldBe` "No API changes.\n" + + it "highlights the differing tokens" $ + highlightPair "f :: (A, B) => C" "f :: (A) => C" + `shouldBe` + ( [Plain "f :: (A", Highlight ", B", Plain ") => C"] + , [Plain "f :: (A", Plain ") => C"] + ) + + it "colors lines when asked" $ + renderLines True [Line 0 StyleAdded [Plain "[+] x"]] + `shouldSatisfy` (/= "[+] x\n") + +-------------------------------------------------------------------------------- +-- Refs, options and helpers +-------------------------------------------------------------------------------- + +refSpec :: Spec +refSpec = describe "Ref" $ do + it "parses refs" $ do + parseRef "." `shouldBe` Right RefCwd + parseRef "hackage" `shouldBe` Right (RefHackage HackageLatest) + parseRef "hackage:latest" `shouldBe` Right (RefHackage HackageLatest) + parseRef "hackage:1.2" `shouldBe` Right (RefHackage (HackageVersion "1.2")) + parseRef "git:hackage" `shouldBe` Right (RefGit "hackage") + parseRef "v1.2.0" `shouldBe` Right (RefGit "v1.2.0") + parseRef "file:api.txt" `shouldBe` Right (RefFile "api.txt") + parseRef "foo:bar" `shouldSatisfy` either (const True) (const False) + parseRef "-x" `shouldSatisfy` either (const True) (const False) + + it "classifies repositories" $ do + classifyRepo True "../repo" `shouldBe` Right (Left "../repo") + classifyRepo False "https://github.com/a/b" + `shouldBe` Right (Right "https://github.com/a/b") + classifyRepo False "git@github.com:a/b" `shouldBe` Right (Right "git@github.com:a/b") + classifyRepo False "nothing" `shouldSatisfy` either (const True) (const False) + + it "fills in default refs" $ do + defaultRefs CmdDiff [] `shouldBe` Right ["HEAD", "."] + defaultRefs CmdCheck ["v1"] `shouldBe` Right ["v1", "."] + defaultRefs CmdApi [] `shouldBe` Right ["."] + defaultRefs CmdApi ["a", "b"] `shouldSatisfy` either (const True) (const False) + + it "finds revisions in git ls-remote output" $ do + let out = + [ "1111111111111111111111111111111111111111\tHEAD" + , "2222222222222222222222222222222222222222\trefs/heads/master" + , "3333333333333333333333333333333333333333\trefs/tags/v1" + , "4444444444444444444444444444444444444444\trefs/tags/v1^{}" + ] + matchRemoteRef out "master" `shouldBe` Just (replicate 40 '2') + matchRemoteRef out "v1" `shouldBe` Just (replicate 40 '4') + matchRemoteRef out "HEAD" `shouldBe` Just (replicate 40 '1') + matchRemoteRef out "v1~1" `shouldBe` Nothing + +optionsSpec :: Spec +optionsSpec = describe "Options" $ do + let parse = parseOptionsPure "packdiff" + it "parses a diff command" $ + fmap (\o -> (optCommand o, optRefs o, optPackage o)) (either (Left . fst) Right (parse ["diff", "-p", "x", "v1", "v2"])) + `shouldBe` Right (CmdDiff, ["v1", "v2"], Just "x") + + it "combines comma separated and repeated change types" $ + fmap optShow (either (Left . fst) Right (parse ["diff", "--show", "added,removed", "--show", "changed"])) + `shouldBe` Right (Just (Set.fromList [Added, Removed, Changed])) + + it "exits with 2 on a usage error" $ + either (Just . snd) (const Nothing) (parse ["diff", "--bogus"]) + `shouldBe` Just (ExitFailure 2) + + it "does not accept --fail-on for api" $ + either (Just . snd) (const Nothing) (parse ["api", "--fail-on", "any"]) + `shouldBe` Just (ExitFailure 2) + +helpersSpec :: Spec +helpersSpec = describe "Helpers" $ do + it "matches globs" $ do + globMatch "*.Internal.*" "Streamly.Internal.Data.Fold" `shouldBe` True + globMatch "*.Internal" "Streamly.Data.Internal" `shouldBe` True + globMatch "*.Internal" "Streamly.Internal.Data" `shouldBe` False + globMatch "Streamly.Data.*" "Streamly.Data.Fold" `shouldBe` True + globMatch "A" "AB" `shouldBe` False + + it "hashes with FNV-1a" $ do + fnv1a64 "" `shouldBe` 0xcbf29ce484222325 + fnv1a64 "a" `shouldBe` 0xaf63dc4c8601ec8c + hashHex "" `shouldBe` "cbf29ce484222325" + + it "names cache entries" $ + cacheFileName (CacheKey "streamly" "abc" "9.10.3" "2.31.1" []) + `shouldBe` "streamly-abc-ghc-9.10.3-haddock-2.31.1-" + ++ hashHex "[]" ++ ".txt" + + it "parses work directory names" $ do + parsePidPrefix "1234-abc" `shouldBe` Just 1234 + parsePidPrefix "abc" `shouldBe` Nothing + + it "finds the hoogle file in cabal output" $ do + hoogleFileFromOutput "Documentation created:\n/a/b/p.txt\n" + `shouldBe` Just "/a/b/p.txt" + hoogleFileFromOutput "Documentation created: dist/p/index.html,\ndist/p/p.txt\n" + `shouldBe` Just "dist/p/p.txt" + hoogleFileFromOutput "nothing here\n" `shouldBe` Nothing + + it "parses cabal list output" $ do + let out = "streamly 0.10.1\nstreamly 0.9.0\nstreamly-core 0.2.2\n" + vs = parseVersionList "streamly" out + vs `shouldBe` [[0, 10, 1], [0, 9, 0]] + latestVersion vs `shouldBe` Just [0, 10, 1] + +-------------------------------------------------------------------------------- +-- Main +-------------------------------------------------------------------------------- + +main :: IO () +main = hspec $ do + parserSpec + diffSpec + prettySpec + refSpec + optionsSpec + helpersSpec diff --git a/test/data/new.txt b/test/data/new.txt new file mode 100644 index 0000000..05b6b58 --- /dev/null +++ b/test/data/new.txt @@ -0,0 +1,69 @@ +-- Hoogle documentation, generated by Haddock +-- See Hoogle, http://www.haskell.org/hoogle/ + + +-- | A test package +@package testpkg +@version 1.2.1.0 + + +-- | Folds. +module Test.Fold + +-- | Step of a fold. +data Step s b +Partial :: !s -> Step s b +Done :: !b -> Step s b + +-- | A fold. +newtype Fold (m :: Type -> Type) a b +Fold :: (s -> a -> m (Step s b)) -> Fold m a b + +-- | Deprecated: Do not use. +[foldStep] :: Fold m a b -> s -> a -> m (Step s b) + +type Config = Int + +-- | A class with an associated type. +class IsMap (f :: Type -> Type) where { + type Key (f :: Type -> Type); +} +mapEmpty :: IsMap f => f a +mapInsert :: IsMap f => Key f -> a -> f a -> f a +mapDelete :: IsMap f => Key f -> f a -> f a + +class Monad m => MonadAsync m +instance Monad m => Functor (Fold m a) +instance Monad m => Applicative (Fold m a) + +pattern Partial :: s -> Step s b + +-- | Fold to a hash map. +toHashMapIO :: (MonadIO m, Hashable k) => (a -> k) -> Fold m a b -> Fold m a (HashMap k b) +toListOld :: Fold m a [a] +sum :: (Monad m, Num a) => Fold m a a +(<>) :: Fold m a b -> Fold m a b -> Fold m a b +infixr 5 <> + +-- | New module. +module Test.Scanl +data Scanl m a b +scanl :: Fold m a b -> Scanl m a b + +module Test.Prelude +useAcquire :: AcquireIO -> Config -> Config + +-- | Deprecated: Use parEvalNew. +parEval :: MonadAsync m => (Config -> Config) -> Stream m a -> Stream m a +config :: Config + +module Test.Stable +stable :: Int + +-- | Deprecated: Use Test.Stable. +module Test.ToBeDeprecated +dep :: Int + +module Test.Internal.Fold +foldtM :: Int +foldtM' :: Int diff --git a/test/data/old.txt b/test/data/old.txt new file mode 100644 index 0000000..f31a02c --- /dev/null +++ b/test/data/old.txt @@ -0,0 +1,63 @@ +-- Hoogle documentation, generated by Haddock +-- See Hoogle, http://www.haskell.org/hoogle/ + + +-- | A test package +@package testpkg +@version 1.2.0.0 + + +-- | Folds. +module Test.Fold + +-- | Step of a fold. +data Step s b +Done :: !b -> Step s b + +-- | A fold. +newtype Fold m a b +Fold :: (s -> a -> m (Step s b)) -> Fold m a b +[foldStep] :: Fold m a b -> s -> a -> m (Step s b) + +type Config = Int + +-- | A class with an associated type. +class IsMap (f :: Type -> Type) where { + type Key (f :: Type -> Type); +} +mapEmpty :: IsMap f => f a +mapInsert :: IsMap f => Key f -> a -> f a -> f a + +class Monad m => MonadAsync m +instance Monad m => Functor (Fold m a) +instance Show (Step s b) + +pattern Partial :: s -> Step s b + +-- | Fold to a hash map. +toHashMapIO :: (MonadIO m, Hashable k, Ord k) => (a -> k) -> Fold m a b -> Fold m a (HashMap k b) + +-- | Deprecated: Use toList instead. +toListOld :: Fold m a [a] +sum :: (Monad m, Num a) => Fold m a a +(<>) :: Fold m a b -> Fold m a b -> Fold m a b +removedFn :: Int -> Int +infixr 6 <> + +-- | Old module. +module Test.Unfold.Old +unfoldOld :: Int -> Int +unfoldOld2 :: Int -> Int + +module Test.Prelude +parEval :: MonadAsync m => (Config -> Config) -> Stream m a -> Stream m a +config :: Config + +module Test.Stable +stable :: Int + +module Test.ToBeDeprecated +dep :: Int + +module Test.Internal.Fold +foldtM :: Int diff --git a/test/data/pkga.txt b/test/data/pkga.txt new file mode 100644 index 0000000..ab5aaea --- /dev/null +++ b/test/data/pkga.txt @@ -0,0 +1,13 @@ +-- Hoogle documentation, generated by Haddock + +@package pkga +@version 0.1 + +module A.One +one :: Int + +-- | Deprecated: use one. +module A.Two +data T +T :: Int -> T +two :: T diff --git a/test/data/pkgb.txt b/test/data/pkgb.txt new file mode 100644 index 0000000..7937a94 --- /dev/null +++ b/test/data/pkgb.txt @@ -0,0 +1,10 @@ +-- Hoogle documentation, generated by Haddock + +@package pkgb +@version 0.2 + +module B.One +class C a +c :: C a => a -> Int +instance C Int +infixl 4 `c` diff --git a/test/golden/api.out b/test/golden/api.out new file mode 100644 index 0000000..3801587 --- /dev/null +++ b/test/golden/api.out @@ -0,0 +1,37 @@ +[+] Test.Fold + [+] newtype Fold (m :: Type -> Type) a b + [+] Fold :: (s -> a -> m (Step s b)) -> Fold m a b + [+] [foldStep] :: Fold m a b -> s -> a -> m (Step s b) + [+] data Step s b + [+] Partial :: !s -> Step s b + [+] Done :: !b -> Step s b + [+] type Config = Int + [+] class IsMap (f :: Type -> Type) where { type Key (f :: Type -> Type); } + [+] mapEmpty :: IsMap f => f a + [+] mapInsert :: IsMap f => Key f -> a -> f a -> f a + [+] mapDelete :: IsMap f => Key f -> f a -> f a + [+] class Monad m => MonadAsync m + [+] instance Monad m => Applicative (Fold m a) + [+] instance Monad m => Functor (Fold m a) + [+] pattern Partial :: s -> Step s b + [+] (<>) :: Fold m a b -> Fold m a b -> Fold m a b + [+] sum :: (Monad m, Num a) => Fold m a a + [+] toHashMapIO :: (MonadIO m, Hashable k) => (a -> k) -> Fold m a b -> Fold m a (HashMap k b) + [+] toListOld :: Fold m a [a] + [+] infixr 5 <> +[+] Test.Prelude + [+] config :: Config + [+] parEval :: MonadAsync m => (Config -> Config) -> Stream m a -> Stream m a + [+] useAcquire :: AcquireIO -> Config -> Config +[+] Test.Scanl + [+] data Scanl m a b + [+] scanl :: Fold m a b -> Scanl m a b +[+] Test.Stable + [+] stable :: Int +[+] Test.ToBeDeprecated + [+] dep :: Int + +Internal modules: +[+] Test.Internal.Fold + [+] foldtM :: Int + [+] foldtM' :: Int diff --git a/test/golden/diff-group-by-change.out b/test/golden/diff-group-by-change.out new file mode 100644 index 0000000..7525b33 --- /dev/null +++ b/test/golden/diff-group-by-change.out @@ -0,0 +1,41 @@ +Removed: +[-] Test.Unfold.Old (2 symbols) +[-] Test.Fold: instance Show (Step s b) +[-] Test.Fold.removedFn :: Int -> Int + +Changed: +[~] newtype Test.Fold.Fold (m :: Type -> Type) a b + - newtype Fold m a b + + newtype Fold (m :: Type -> Type) a b + [D] [foldStep] :: Fold m a b -> s -> a -> m (Step s b) +[~] data Test.Fold.Step s b + [+] Partial :: !s -> Step s b +[~] class Test.Fold.IsMap (f :: Type -> Type) where { type Key (f :: Type -> Type); } + [+] mapDelete :: IsMap f => Key f -> f a -> f a +[~] Test.Fold.toHashMapIO + - toHashMapIO :: (MonadIO m, Hashable k, Ord k) => (a -> k) -> Fold m a b -> Fold m a (HashMap k b) + + toHashMapIO :: (MonadIO m, Hashable k) => (a -> k) -> Fold m a b -> Fold m a (HashMap k b) +[~] Test.Fold.<> + - infixr 6 <> + + infixr 5 <> + +Deprecated: +[D] Test.ToBeDeprecated +[D] Test.Prelude.parEval :: MonadAsync m => (Config -> Config) -> Stream m a -> Stream m a + +Undeprecated: +[U] Test.Fold.toListOld :: Fold m a [a] + +Added: +[+] Test.Scanl (2 symbols) +[+] Test.Fold: instance Monad m => Applicative (Fold m a) +[+] Test.Prelude.useAcquire :: AcquireIO -> Config -> Config + +Internal modules: +Added: +[+] Test.Internal.Fold.foldtM' :: Int + +Modules: 1 added [+], 1 removed [-], 2 changed [~], 1 deprecated [D] +Symbols: 4 added [+], 2 removed [-], 5 changed [~], 2 deprecated [D], 1 undeprecated [U] +Internal modules: 1 changed [~] +Breaking changes: 8 diff --git a/test/golden/diff-modules-only.out b/test/golden/diff-modules-only.out new file mode 100644 index 0000000..9f86556 --- /dev/null +++ b/test/golden/diff-modules-only.out @@ -0,0 +1,13 @@ +[~] Test.Fold +[~] Test.Prelude +[+] Test.Scanl (2 symbols) +[D] Test.ToBeDeprecated +[-] Test.Unfold.Old (2 symbols) + +Internal modules: +[~] Test.Internal.Fold + +Modules: 1 added [+], 1 removed [-], 2 changed [~], 1 deprecated [D] +Symbols: 4 added [+], 2 removed [-], 5 changed [~], 2 deprecated [D], 1 undeprecated [U] +Internal modules: 1 changed [~] +Breaking changes: 8 diff --git a/test/golden/diff-quiet.out b/test/golden/diff-quiet.out new file mode 100644 index 0000000..07f2ae3 --- /dev/null +++ b/test/golden/diff-quiet.out @@ -0,0 +1,4 @@ +Modules: 1 added [+], 1 removed [-], 2 changed [~], 1 deprecated [D] +Symbols: 4 added [+], 2 removed [-], 5 changed [~], 2 deprecated [D], 1 undeprecated [U] +Internal modules: 1 changed [~] +Breaking changes: 8 diff --git a/test/golden/diff-show-added.out b/test/golden/diff-show-added.out new file mode 100644 index 0000000..c39657c --- /dev/null +++ b/test/golden/diff-show-added.out @@ -0,0 +1,18 @@ +[~] Test.Fold + [~] data Step s b + [+] Partial :: !s -> Step s b + [~] class IsMap (f :: Type -> Type) where { type Key (f :: Type -> Type); } + [+] mapDelete :: IsMap f => Key f -> f a -> f a + [+] instance Monad m => Applicative (Fold m a) +[~] Test.Prelude + [+] useAcquire :: AcquireIO -> Config -> Config +[+] Test.Scanl (2 symbols) + +Internal modules: +[~] Test.Internal.Fold + [+] foldtM' :: Int + +Modules: 1 added [+], 1 removed [-], 2 changed [~], 1 deprecated [D] +Symbols: 4 added [+], 2 removed [-], 5 changed [~], 2 deprecated [D], 1 undeprecated [U] +Internal modules: 1 changed [~] +Breaking changes: 8 diff --git a/test/golden/diff.out b/test/golden/diff.out new file mode 100644 index 0000000..5805c2d --- /dev/null +++ b/test/golden/diff.out @@ -0,0 +1,34 @@ +[~] Test.Fold + [~] newtype Fold (m :: Type -> Type) a b + - newtype Fold m a b + + newtype Fold (m :: Type -> Type) a b + [D] [foldStep] :: Fold m a b -> s -> a -> m (Step s b) + [~] data Step s b + [+] Partial :: !s -> Step s b + [~] class IsMap (f :: Type -> Type) where { type Key (f :: Type -> Type); } + [+] mapDelete :: IsMap f => Key f -> f a -> f a + [+] instance Monad m => Applicative (Fold m a) + [-] instance Show (Step s b) + [-] removedFn :: Int -> Int + [~] toHashMapIO + - toHashMapIO :: (MonadIO m, Hashable k, Ord k) => (a -> k) -> Fold m a b -> Fold m a (HashMap k b) + + toHashMapIO :: (MonadIO m, Hashable k) => (a -> k) -> Fold m a b -> Fold m a (HashMap k b) + [U] toListOld :: Fold m a [a] + [~] <> + - infixr 6 <> + + infixr 5 <> +[~] Test.Prelude + [D] parEval :: MonadAsync m => (Config -> Config) -> Stream m a -> Stream m a + [+] useAcquire :: AcquireIO -> Config -> Config +[+] Test.Scanl (2 symbols) +[D] Test.ToBeDeprecated +[-] Test.Unfold.Old (2 symbols) + +Internal modules: +[~] Test.Internal.Fold + [+] foldtM' :: Int + +Modules: 1 added [+], 1 removed [-], 2 changed [~], 1 deprecated [D] +Symbols: 4 added [+], 2 removed [-], 5 changed [~], 2 deprecated [D], 1 undeprecated [U] +Internal modules: 1 changed [~] +Breaking changes: 8 From f4679db858fcee0f5b6f66b282b4d701b6c78242 Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Mon, 12 Oct 2026 18:51:53 +0530 Subject: [PATCH 05/11] Fix hlint suggestions --- src/PackDiff/Cabal.hs | 2 +- src/PackDiff/Git.hs | 11 ++++++----- src/PackDiff/HoogleFileParser.hs | 8 ++------ src/PackDiff/Main.hs | 3 ++- src/PackDiff/Obtain.hs | 6 ++++-- src/PackDiff/Options.hs | 30 ++++++++++++++---------------- test/Main.hs | 4 ++-- 7 files changed, 31 insertions(+), 33 deletions(-) diff --git a/src/PackDiff/Cabal.hs b/src/PackDiff/Cabal.hs index fe4ed7f..644c632 100644 --- a/src/PackDiff/Cabal.hs +++ b/src/PackDiff/Cabal.hs @@ -100,7 +100,7 @@ trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace -- hoogle file, so its human readable output is used. hoogleFileFromOutput :: String -> Maybe FilePath hoogleFileFromOutput out = - case filter (".txt" `isSuffixOf`) (concatMap candidates (lines out)) of + case concatMap (filter (".txt" `isSuffixOf`) . candidates) (lines out) of [] -> Nothing xs -> Just (last xs) diff --git a/src/PackDiff/Git.hs b/src/PackDiff/Git.hs index 472935e..c3f6d4e 100644 --- a/src/PackDiff/Git.hs +++ b/src/PackDiff/Git.hs @@ -26,6 +26,7 @@ module PackDiff.Git , checkout ) where +import Control.Monad (void) import Data.Char (isHexDigit, isSpace) import Data.Maybe (listToMaybe) @@ -35,7 +36,7 @@ import PackDiff.Process type Sha = String git :: FilePath -> [String] -> Cmd -git dir args = Cmd (Just dir) "git" args +git dir = Cmd (Just dir) "git" trim :: String -> String trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace @@ -131,15 +132,15 @@ currentBranch repo = do -- source repository through @.git/objects/info/alternates@. cloneShared :: FilePath -> FilePath -> FilePath -> IO () cloneShared cwd repo dest = - () <$ runCmd (git cwd ["clone", "-q", "--shared", "--no-checkout", repo, dest]) + void $ runCmd (git cwd ["clone", "-q", "--shared", "--no-checkout", repo, dest]) initRepo :: FilePath -> FilePath -> IO () -initRepo cwd dest = () <$ runCmd (git cwd ["init", "-q", dest]) +initRepo cwd dest = void $ runCmd (git cwd ["init", "-q", dest]) -- | Fetch only the files of one commit. fetchSha :: FilePath -> String -> Sha -> IO () fetchSha repo url sha = - () <$ runCmd (git repo ["fetch", "-q", "--depth", "1", url, sha]) + void $ runCmd (git repo ["fetch", "-q", "--depth", "1", url, sha]) checkout :: FilePath -> String -> IO () -checkout repo rev = () <$ runCmd (git repo ["checkout", "-q", rev]) +checkout repo rev = void $ runCmd (git repo ["checkout", "-q", rev]) diff --git a/src/PackDiff/HoogleFileParser.hs b/src/PackDiff/HoogleFileParser.hs index 48fcf19..0d60c90 100644 --- a/src/PackDiff/HoogleFileParser.hs +++ b/src/PackDiff/HoogleFileParser.hs @@ -21,7 +21,7 @@ module PackDiff.HoogleFileParser import Data.Char (isSpace, isUpper) import Data.Function ((&)) -import Data.List (isInfixOf, isPrefixOf, stripPrefix) +import Data.List (isInfixOf, isPrefixOf, isSuffixOf, stripPrefix) import Data.Maybe (isNothing) import Streamly.Data.Fold (Fold) import Streamly.Data.Stream (Stream) @@ -244,7 +244,7 @@ topLevel line st1 = ("newtype" : _) -> open KData (nameAfterKeyword line) ("type" : _) -> insert KTypeSyn (nameAfterKeyword line) ("class" : _) -> - let multiline = "{" `isSuffixOf'` line + let multiline = "{" `isSuffixOf` line cls = className line in st { stOpen = OpenClass cls multiline (mkDecl KClass cls line doc) } ("instance" : _) -> @@ -255,10 +255,6 @@ topLevel line st1 = insert KFixity (unwords ops) _ -> insert KFunction (takeWhile (not . isSpace) line) - where - - isSuffixOf' s x = reverse s `isPrefixOf` reverse x - -- | A continuation line of a multi line class declaration, e.g. an associated -- type. It is appended to the class declaration so that the declaration -- stays on one line. diff --git a/src/PackDiff/Main.hs b/src/PackDiff/Main.hs index 8dda180..72ade05 100644 --- a/src/PackDiff/Main.hs +++ b/src/PackDiff/Main.hs @@ -25,6 +25,7 @@ import Control.Exception , uninterruptibleMask_ ) import Data.Function ((&)) +import Data.Maybe (isNothing) import System.Console.ANSI (hSupportsANSI) import System.Environment (lookupEnv) import System.Exit (ExitCode(..), exitWith) @@ -298,7 +299,7 @@ run opts = do let inPlaceRefs = [ a | a <- args , raRef a == RefCwd - || isGitRef (raRef a) && raRepoFlag a == Nothing + || isGitRef (raRef a) && isNothing (raRepoFlag a) ] if optInPlace opts && not (null inPlaceRefs) then do diff --git a/src/PackDiff/Obtain.hs b/src/PackDiff/Obtain.hs index b72f754..2fda5f7 100644 --- a/src/PackDiff/Obtain.hs +++ b/src/PackDiff/Obtain.hs @@ -1,4 +1,5 @@ {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} -- | -- Module : PackDiff.Obtain -- Copyright : (c) 2022 Composewell Technologies @@ -33,6 +34,7 @@ import Control.Monad (unless, when) import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef') import Data.List (nub) import Data.Map (Map) +import Data.Maybe (isJust) import System.Directory (doesDirectoryExist, doesFileExist, makeAbsolute) import System.IO (hPutStrLn, stderr) @@ -65,7 +67,7 @@ requiredPrograms bc inPlace = nub . concatMap needs build = ["cabal", compilerProgram bc, haddockProgram bc] needs (s, ref) = - map (\p -> (p, s)) $ + map (, s) $ case ref of RefGit _ -> "git" : build RefCwd -> [ "git" | inPlace ] ++ build @@ -76,7 +78,7 @@ requiredPrograms bc inPlace = nub . concatMap needs programExists :: String -> IO Bool programExists p | any (`elem` "/\\") p = doesFileExist p - | otherwise = fmap (maybe False (const True)) (Which.which p) + | otherwise = fmap isJust (Which.which p) -- | Exit with a usage error if a program needed by a ref is missing. checkPrograms :: [(String, String)] -> IO () diff --git a/src/PackDiff/Options.hs b/src/PackDiff/Options.hs index f1fd95f..ff8f364 100644 --- a/src/PackDiff/Options.hs +++ b/src/PackDiff/Options.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} -- | -- Module : PackDiff.Options -- Copyright : (c) 2022 Composewell Technologies @@ -166,19 +167,17 @@ data OutputOpts = (Maybe (Set Change)) (Maybe (Set Change)) Bool colorReader :: ReadM ColorMode -colorReader = eitherReader $ \s -> - case s of - "auto" -> Right ColorAuto - "always" -> Right ColorAlways - "never" -> Right ColorNever - _ -> Left "expected auto, always or never" +colorReader = eitherReader $ \case + "auto" -> Right ColorAuto + "always" -> Right ColorAlways + "never" -> Right ColorNever + _ -> Left "expected auto, always or never" groupByReader :: ReadM GroupBy -groupByReader = eitherReader $ \s -> - case s of - "module" -> Right GroupByModule - "change" -> Right GroupByChange - _ -> Left "expected module or change" +groupByReader = eitherReader $ \case + "module" -> Right GroupByModule + "change" -> Right GroupByChange + _ -> Left "expected module or change" colorOpt :: Parser ColorMode colorOpt = @@ -221,11 +220,10 @@ formatOpt = where - reader = eitherReader $ \s -> - case s of - "text" -> Right FormatText - "hoogle" -> Right FormatHoogle - _ -> Left "expected text or hoogle" + reader = eitherReader $ \case + "text" -> Right FormatText + "hoogle" -> Right FormatHoogle + _ -> Left "expected text or hoogle" refsArg :: String -> Parser [String] refsArg meta = many (strArgument (metavar meta)) diff --git a/test/Main.hs b/test/Main.hs index ee6943d..e185765 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -180,8 +180,8 @@ diffSpec = describe "Diff" $ do breakingCount (Map.elems rel) `shouldBe` 8 it "does not count a child deprecation as breaking" $ do - let child c d = Child c c d - decl cs = Decl KData "T" "data T" [] False cs + let child c = Child c c + decl = Decl KData "T" "data T" [] False dd = DeclDiff Changed (Just (decl [child "A" False])) (Just (decl [child "A" True])) [ChildDiff Deprecated (Just (child "A" False)) (Just (child "A" True))] From 1e79e1ed31b1e3b11b57b85c9b1708ebf18549fc Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Mon, 12 Oct 2026 18:58:28 +0530 Subject: [PATCH 06/11] Show the refs being compared in diff and check output --- src/PackDiff/Main.hs | 25 +++++++++++++++++-------- 1 file changed, 17 insertions(+), 8 deletions(-) diff --git a/src/PackDiff/Main.hs b/src/PackDiff/Main.hs index 72ade05..ce434c1 100644 --- a/src/PackDiff/Main.hs +++ b/src/PackDiff/Main.hs @@ -214,6 +214,8 @@ diffCommand :: Env -> Options -> RefArg -> RefArg -> IO ExitCode diffCommand env opts a1 a2 = do visible <- visibility opts color <- useColor (optColor opts) + hPutStrLn stderr $ + "packdiff: comparing " ++ raString a1 ++ " with " ++ raString a2 (o1, o2) <- obtainPair env opts a1 a2 let (released, internal) = diffPair opts o1 o2 ro = RenderOptions @@ -240,6 +242,9 @@ versionOf a ob = checkCommand :: Env -> Options -> RefArg -> RefArg -> IO ExitCode checkCommand env opts a1 a2 = do + hPutStrLn stderr $ + "packdiff: checking the version of " ++ raString a2 + ++ " against " ++ raString a1 (o1, o2) <- obtainPair env opts a1 a2 base <- versionOf a1 o1 declared <- versionOf a2 o2 @@ -248,18 +253,22 @@ checkCommand env opts a1 a2 = do bump = requiredBump mds required = bumpVersion bump base sufficient = compareVersion declared required /= LT - reason = + label a v = raString a ++ " (" ++ showVersion v ++ ")" + (changes, bumpName) = case bump of - BumpMajor -> "breaking changes detected: bump major" + BumpMajor -> ("breaking changes", "major") BumpMinor | hasChangeIn (Set.singleton Added) mds -> - "new symbols added: bump minor" - | otherwise -> "non-breaking changes detected: bump minor" - BumpPatch -> "no API changes detected: bump patch" - putStrLn $ reason ++ " (" ++ showVersion required ++ ")" + ("new symbols added", "minor") + | otherwise -> ("non-breaking changes", "minor") + BumpPatch -> ("no API changes", "patch") putStrLn $ - "declared version " ++ showVersion declared ++ " is " - ++ if sufficient then "sufficient" else "insufficient" + changes ++ " between " ++ label a1 base ++ " and " + ++ label a2 declared ++ ": bump " ++ bumpName ++ " (" + ++ showVersion required ++ ")" + putStrLn $ + "declared version " ++ showVersion declared ++ " of " ++ raString a2 + ++ " is " ++ if sufficient then "sufficient" else "insufficient" pure (if sufficient then ExitSuccess else ExitFailure 1) apiCommand :: Env -> Options -> RefArg -> IO ExitCode From 3fc7472030581537d3f0df3c90aeeb4fd2b2a3ff Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Mon, 12 Oct 2026 19:30:21 +0530 Subject: [PATCH 07/11] Add --expand, rename --modules-only to --collapse --expand lists the symbols of added and removed modules under their module lines. --collapse and --expand cannot be used together. --- README.md | 4 ++ dev/design.md | 13 ++++-- src/PackDiff/Main.hs | 24 ++++++---- src/PackDiff/Options.hs | 16 ++++--- src/PackDiff/Pretty.hs | 45 ++++++++++++------ test/Main.hs | 13 +++++- ...iff-modules-only.out => diff-collapse.out} | 0 test/golden/diff-expand-group-by-change.out | 46 +++++++++++++++++++ test/golden/diff-expand.out | 38 +++++++++++++++ 9 files changed, 165 insertions(+), 34 deletions(-) rename test/golden/{diff-modules-only.out => diff-collapse.out} (100%) create mode 100644 test/golden/diff-expand-group-by-change.out create mode 100644 test/golden/diff-expand.out diff --git a/README.md b/README.md index adfa135..5aa8bb5 100644 --- a/README.md +++ b/README.md @@ -69,6 +69,10 @@ Breaking changes: 2 | `[D]` | Deprecated in `REF2`, not deprecated in `REF1`. | | `[U]` | Deprecated in `REF1`, not deprecated in `REF2`. | +Added and removed modules show only their symbol count. `--expand` also +lists their symbols. `--collapse` prints only the module lines, and `-q` +only the summary. + Modules matching `--internal-module` (default `*.Internal.*` and `*.Internal`) are listed separately under `Internal modules:` and do not count towards `--fail-on`, `check` or the breaking change count. diff --git a/dev/design.md b/dev/design.md index fbd3b29..f69e2b0 100644 --- a/dev/design.md +++ b/dev/design.md @@ -390,8 +390,10 @@ sigils used in the output. Counts that are zero are omitted, and a line whose counts are all zero is omitted. An empty diff prints `No API changes.` -`-q` prints only the summary. `--modules-only` prints the module lines -and the summary. +`-q` prints only the summary. `--collapse` prints the module lines and +the summary. `--expand` also lists the symbols of added and removed +modules under their module lines; `--collapse` and `--expand` cannot be +used together. ### Grouping by change @@ -470,7 +472,8 @@ The flags for refs (`--repo`, `--old-repo`, `--new-repo`) and packages | `--color ` | Color control: `auto` (default), `always`, `never`. `auto` disables color when `NO_COLOR` is set or stdout is not a terminal. | | `--group-by ` | `module` (default): changes grouped by module. `change`: one section per change kind, for use in a changelog. See [Grouping by change](#grouping-by-change). | | `-q / --quiet` | Print only the summary. | -| `--modules-only` | Print only the module lines and the summary. | +| `--collapse` | Print only the module lines and the summary. | +| `--expand` | Also list the symbols of added and removed modules. | ### Filtering @@ -499,8 +502,8 @@ Filters apply in this order: modules are diffed and printed in their own section, but never count towards `--fail-on`. 2. `--fail-on` is evaluated on the result. -3. `--show`, `--hide`, `--breaking-only`, `-q` and `--modules-only` - affect only what is printed. They do not change the exit code. +3. `--show`, `--hide`, `--breaking-only`, `-q`, `--collapse` and + `--expand` affect only what is printed. They do not change the exit code. Exit codes: diff --git a/src/PackDiff/Main.hs b/src/PackDiff/Main.hs index ce434c1..49186e8 100644 --- a/src/PackDiff/Main.hs +++ b/src/PackDiff/Main.hs @@ -24,6 +24,7 @@ import Control.Exception , throwIO , uninterruptibleMask_ ) +import Control.Monad (when) import Data.Function ((&)) import Data.Maybe (isNothing) import System.Console.ANSI (hSupportsANSI) @@ -197,6 +198,19 @@ visibility opts = (s, False) -> s (s, True) -> Just (maybe breaking (Set.union breaking) s) +renderOptions :: Options -> IO RenderOptions +renderOptions opts = do + visible <- visibility opts + when (optCollapse opts && optExpand opts) $ + usageError "--collapse and --expand cannot be used together" + pure RenderOptions + { roGroupBy = optGroupBy opts + , roQuiet = optQuiet opts + , roCollapse = optCollapse opts + , roExpand = optExpand opts + , roVisible = visible + } + selectedAPI :: Options -> Obtained -> API selectedAPI opts = selectModules (moduleFilter opts) . hoogleAPI . obHoogle @@ -212,18 +226,12 @@ diffPair opts o1 o2 = diffCommand :: Env -> Options -> RefArg -> RefArg -> IO ExitCode diffCommand env opts a1 a2 = do - visible <- visibility opts + ro <- renderOptions opts color <- useColor (optColor opts) hPutStrLn stderr $ "packdiff: comparing " ++ raString a1 ++ " with " ++ raString a2 (o1, o2) <- obtainPair env opts a1 a2 let (released, internal) = diffPair opts o1 o2 - ro = RenderOptions - { roGroupBy = optGroupBy opts - , roQuiet = optQuiet opts - , roModulesOnly = optModulesOnly opts - , roVisible = visible - } putStr $ renderLines color (renderDiff ro released internal) pure $ case optFailOn opts of Just cs | hasChangeIn cs (Map.elems released) -> ExitFailure 1 @@ -291,7 +299,7 @@ apiCommand env opts a = do run :: Options -> IO ExitCode run opts = do args <- refArgs opts - _ <- visibility opts -- report conflicting flags before any work + _ <- renderOptions opts -- report conflicting flags before any work let bc = BuildConfig (optCompiler opts) (optCabalOptions opts) checkPrograms (requiredPrograms bc (optInPlace opts) diff --git a/src/PackDiff/Options.hs b/src/PackDiff/Options.hs index ff8f364..dacba3b 100644 --- a/src/PackDiff/Options.hs +++ b/src/PackDiff/Options.hs @@ -65,7 +65,8 @@ data Options = Options , optColor :: ColorMode , optGroupBy :: GroupBy , optQuiet :: Bool - , optModulesOnly :: Bool + , optCollapse :: Bool + , optExpand :: Bool , optFormat :: Format -- Filtering , optShow :: Maybe (Set Change) @@ -163,7 +164,7 @@ buildOpts = \them out in the current working tree.") data OutputOpts = - OutputOpts ColorMode GroupBy Bool Bool + OutputOpts ColorMode GroupBy Bool Bool Bool (Maybe (Set Change)) (Maybe (Set Change)) Bool colorReader :: ReadM ColorMode @@ -194,8 +195,10 @@ outputOpts = (long "group-by" <> metavar "G" <> value GroupByModule <> help "module (default) or change.") <*> switch (short 'q' <> long "quiet" <> help "Print only the summary.") - <*> switch (long "modules-only" + <*> switch (long "collapse" <> help "Print only the module lines and the summary.") + <*> switch (long "expand" + <> help "Also list the symbols of added and removed modules.") <*> changeSets parseChangeTypes (long "show" <> metavar "TYPES" <> help "Show only these change types: added, removed, \ @@ -246,7 +249,7 @@ mkOptions :: mkOptions cmd refs (RepoOpts repo old new) pkg (ModuleOpts mods ignores internals) (BuildOpts compiler cabalOpts noCache workDir inPlace) - (OutputOpts color groupBy quiet modsOnly shw hide breakingOnly) + (OutputOpts color groupBy quiet collapse expand shw hide breakingOnly) failOn fmt = Options { optCommand = cmd @@ -258,7 +261,8 @@ mkOptions cmd refs (RepoOpts repo old new) pkg , optColor = color , optGroupBy = groupBy , optQuiet = quiet - , optModulesOnly = modsOnly + , optCollapse = collapse + , optExpand = expand , optFormat = fmt , optShow = shw , optHide = hide @@ -276,7 +280,7 @@ mkOptions cmd refs (RepoOpts repo old new) pkg defaultOutputOpts :: ColorMode -> OutputOpts defaultOutputOpts color = - OutputOpts color GroupByModule False False Nothing Nothing False + OutputOpts color GroupByModule False False False Nothing Nothing False diffParser :: Parser Options diffParser = diff --git a/src/PackDiff/Pretty.hs b/src/PackDiff/Pretty.hs index c3d0024..db9eaaa 100644 --- a/src/PackDiff/Pretty.hs +++ b/src/PackDiff/Pretty.hs @@ -255,6 +255,17 @@ declLines visible qual lvl dd else [] (c, _, _) -> [sigilLine lvl c (qual d (declText d))] +-- | The declarations of a module and their children, all marked with the +-- same sigil. +moduleSymbolLines :: Change -> Int -> Module -> [Line] +moduleSymbolLines c lvl m = concatMap decl (Map.elems (moduleDecls m)) + + where + + decl d = + sigilLine lvl c (declText d) + : map (sigilLine (lvl + 1) c . childText) (declChildren d) + symbols :: Int -> String symbols 1 = "(1 symbol)" symbols n = "(" ++ show n ++ " symbols)" @@ -280,7 +291,10 @@ data GroupBy data RenderOptions = RenderOptions { roGroupBy :: GroupBy , roQuiet :: Bool - , roModulesOnly :: Bool + , roCollapse :: Bool + -- ^ Print only the module lines. + , roExpand :: Bool + -- ^ List the symbols of added and removed modules. , roVisible :: Change -> Bool } @@ -289,18 +303,28 @@ defaultRenderOptions = RenderOptions { roGroupBy = GroupByModule , roQuiet = False - , roModulesOnly = False + , roCollapse = False + , roExpand = False , roVisible = const True } +-- | The module line of an added or removed module, followed by its symbols +-- with @--expand@. +addedRemovedLines :: RenderOptions -> ModuleName -> ModuleDiff -> [Line] +addedRemovedLines ro name md = + moduleLine 0 name md + : if roExpand ro + then moduleSymbolLines (mdChange md) 1 (moduleDiffModule md) + else [] + -- | Lines of one module in the output grouped by module. moduleLines :: RenderOptions -> ModuleName -> ModuleDiff -> [Line] moduleLines ro name md = case mdChange md of c | c `elem` [Added, Removed] -> - [moduleLine 0 name md | visible c] + if visible c then addedRemovedLines ro name md else [] c | visible c && c /= Changed || not (null decls) -> - moduleLine 0 name md : if roModulesOnly ro then [] else decls + moduleLine 0 name md : if roCollapse ro then [] else decls _ -> [] where @@ -349,12 +373,13 @@ groupedByChange ro diff = where modItems = - [ moduleLine 0 name md + [ l | visible c, c /= Changed, (name, md) <- mods, mdChange md == c + , l <- addedRemovedLines ro name md ] declItems = [ l - | not (roModulesOnly ro) + | not (roCollapse ro) , (name, md) <- mods , dd <- mdDecls md , ddChange dd == c @@ -430,13 +455,7 @@ renderDiff ro released internal = apiModuleLines :: ModuleName -> Module -> [Line] apiModuleLines name m = - sigilLine 0 Added name : concatMap decl (Map.elems (moduleDecls m)) - - where - - decl d = - sigilLine 1 Added (declText d) - : map (sigilLine 2 Added . childText) (declChildren d) + sigilLine 0 Added name : moduleSymbolLines Added 1 m -- | The API of released and internal modules in the tree format, with every -- entity marked @[+]@. diff --git a/test/Main.hs b/test/Main.hs index e185765..d6cf50d 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -229,8 +229,17 @@ prettySpec = describe "Pretty" $ do >>= golden "diff-show-added" it "renders module lines only" $ - renderTestDiff defaultRenderOptions { roModulesOnly = True } - >>= golden "diff-modules-only" + renderTestDiff defaultRenderOptions { roCollapse = True } + >>= golden "diff-collapse" + + it "renders the symbols of added and removed modules" $ + renderTestDiff defaultRenderOptions { roExpand = True } + >>= golden "diff-expand" + + it "renders the symbols of added and removed modules grouped by change" $ + renderTestDiff + defaultRenderOptions { roExpand = True, roGroupBy = GroupByChange } + >>= golden "diff-expand-group-by-change" it "renders only the summary when quiet" $ renderTestDiff defaultRenderOptions { roQuiet = True } diff --git a/test/golden/diff-modules-only.out b/test/golden/diff-collapse.out similarity index 100% rename from test/golden/diff-modules-only.out rename to test/golden/diff-collapse.out diff --git a/test/golden/diff-expand-group-by-change.out b/test/golden/diff-expand-group-by-change.out new file mode 100644 index 0000000..4c2d3f6 --- /dev/null +++ b/test/golden/diff-expand-group-by-change.out @@ -0,0 +1,46 @@ +Removed: +[-] Test.Unfold.Old (2 symbols) + [-] unfoldOld :: Int -> Int + [-] unfoldOld2 :: Int -> Int +[-] Test.Fold: instance Show (Step s b) +[-] Test.Fold.removedFn :: Int -> Int + +Changed: +[~] newtype Test.Fold.Fold (m :: Type -> Type) a b + - newtype Fold m a b + + newtype Fold (m :: Type -> Type) a b + [D] [foldStep] :: Fold m a b -> s -> a -> m (Step s b) +[~] data Test.Fold.Step s b + [+] Partial :: !s -> Step s b +[~] class Test.Fold.IsMap (f :: Type -> Type) where { type Key (f :: Type -> Type); } + [+] mapDelete :: IsMap f => Key f -> f a -> f a +[~] Test.Fold.toHashMapIO + - toHashMapIO :: (MonadIO m, Hashable k, Ord k) => (a -> k) -> Fold m a b -> Fold m a (HashMap k b) + + toHashMapIO :: (MonadIO m, Hashable k) => (a -> k) -> Fold m a b -> Fold m a (HashMap k b) +[~] Test.Fold.<> + - infixr 6 <> + + infixr 5 <> + +Deprecated: +[D] Test.ToBeDeprecated + [D] dep :: Int +[D] Test.Prelude.parEval :: MonadAsync m => (Config -> Config) -> Stream m a -> Stream m a + +Undeprecated: +[U] Test.Fold.toListOld :: Fold m a [a] + +Added: +[+] Test.Scanl (2 symbols) + [+] data Scanl m a b + [+] scanl :: Fold m a b -> Scanl m a b +[+] Test.Fold: instance Monad m => Applicative (Fold m a) +[+] Test.Prelude.useAcquire :: AcquireIO -> Config -> Config + +Internal modules: +Added: +[+] Test.Internal.Fold.foldtM' :: Int + +Modules: 1 added [+], 1 removed [-], 2 changed [~], 1 deprecated [D] +Symbols: 4 added [+], 2 removed [-], 5 changed [~], 2 deprecated [D], 1 undeprecated [U] +Internal modules: 1 changed [~] +Breaking changes: 8 diff --git a/test/golden/diff-expand.out b/test/golden/diff-expand.out new file mode 100644 index 0000000..0d859b8 --- /dev/null +++ b/test/golden/diff-expand.out @@ -0,0 +1,38 @@ +[~] Test.Fold + [~] newtype Fold (m :: Type -> Type) a b + - newtype Fold m a b + + newtype Fold (m :: Type -> Type) a b + [D] [foldStep] :: Fold m a b -> s -> a -> m (Step s b) + [~] data Step s b + [+] Partial :: !s -> Step s b + [~] class IsMap (f :: Type -> Type) where { type Key (f :: Type -> Type); } + [+] mapDelete :: IsMap f => Key f -> f a -> f a + [+] instance Monad m => Applicative (Fold m a) + [-] instance Show (Step s b) + [-] removedFn :: Int -> Int + [~] toHashMapIO + - toHashMapIO :: (MonadIO m, Hashable k, Ord k) => (a -> k) -> Fold m a b -> Fold m a (HashMap k b) + + toHashMapIO :: (MonadIO m, Hashable k) => (a -> k) -> Fold m a b -> Fold m a (HashMap k b) + [U] toListOld :: Fold m a [a] + [~] <> + - infixr 6 <> + + infixr 5 <> +[~] Test.Prelude + [D] parEval :: MonadAsync m => (Config -> Config) -> Stream m a -> Stream m a + [+] useAcquire :: AcquireIO -> Config -> Config +[+] Test.Scanl (2 symbols) + [+] data Scanl m a b + [+] scanl :: Fold m a b -> Scanl m a b +[D] Test.ToBeDeprecated +[-] Test.Unfold.Old (2 symbols) + [-] unfoldOld :: Int -> Int + [-] unfoldOld2 :: Int -> Int + +Internal modules: +[~] Test.Internal.Fold + [+] foldtM' :: Int + +Modules: 1 added [+], 1 removed [-], 2 changed [~], 1 deprecated [D] +Symbols: 4 added [+], 2 removed [-], 5 changed [~], 2 deprecated [D], 1 undeprecated [U] +Internal modules: 1 changed [~] +Breaking changes: 8 From 3f35f6ab80bd2398391aa46f50f77261b33886da Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Mon, 12 Oct 2026 20:24:28 +0530 Subject: [PATCH 08/11] Group the command help options into sections Use parserOptionGroup from optparse-applicative 0.19 to show the options under Source options, Module selection, Build options, Output options, Change filters and Help options. Pin optparse-applicative 0.19.0.0 in sources.nix for the nix shell. --- flake.nix | 4 +- packdiff.cabal | 2 +- sources.nix | 13 ++++ src/PackDiff/Options.hs | 150 ++++++++++++++++++++++------------------ 4 files changed, 96 insertions(+), 73 deletions(-) create mode 100644 sources.nix diff --git a/flake.nix b/flake.nix index 2a08fc4..4027050 100644 --- a/flake.nix +++ b/flake.nix @@ -11,9 +11,7 @@ basepkgs.nixpack.mkOutputs { inherit nixpkgs nixpkgs-darwin basepkgs; name = "packdiff"; - sources = basepkgs.nixpack.lib.localSource "packdiff" ./.; + sources = import ./sources.nix; packages = basepkgs.nixpack.lib.devPackage "packdiff"; - #sources = import ./sources.nix; - #packages = import ./packages.nix; }; } diff --git a/packdiff.cabal b/packdiff.cabal index cf22c5c..1a60478 100644 --- a/packdiff.cabal +++ b/packdiff.cabal @@ -91,7 +91,7 @@ library , ansi-terminal >= 1.0 && < 1.2 , containers >= 0.6 && < 0.9 , directory >= 1.3 && < 1.4 - , optparse-applicative >= 0.17 && < 0.20 + , optparse-applicative >= 0.19 && < 0.20 , streamly-core >= 0.3 && < 0.4 , streamly-coreutils >= 0.1 && < 0.2 , streamly-process >= 0.4 && < 0.5 diff --git a/sources.nix b/sources.nix new file mode 100644 index 0000000..0c65d54 --- /dev/null +++ b/sources.nix @@ -0,0 +1,13 @@ +{nixpack}: +with nixpack.mkSources; +{ +layers = [ +{ + packdiff = local ./.; + # parserOptionGroup, for help sections, is new in 0.19. + optparse-applicative = + hackage "0.19.0.0" "0cs8fqipakad38lvm75nz98hmvf881mgjhnc7icblxfzh92ay6kn" + // { profiling = true; }; +} +]; +} diff --git a/src/PackDiff/Options.hs b/src/PackDiff/Options.hs index dacba3b..f06d70a 100644 --- a/src/PackDiff/Options.hs +++ b/src/PackDiff/Options.hs @@ -100,35 +100,41 @@ changeSets parse m = combine [] = Nothing combine xs = Just (Set.unions xs) -data RepoOpts = RepoOpts (Maybe String) (Maybe String) (Maybe String) - -repoOpt :: Parser (Maybe String) -repoOpt = - optional $ strOption $ - long "repo" <> metavar "PATH-OR-URL" - <> help "Repository for git refs. Default: the repository of the \ - \current directory." - -oldNewRepoOpts :: Parser (Maybe String, Maybe String) -oldNewRepoOpts = - (,) - <$> optional (strOption $ - long "old-repo" <> metavar "PATH-OR-URL" - <> help "Repository for REF1 only.") - <*> optional (strOption $ - long "new-repo" <> metavar "PATH-OR-URL" - <> help "Repository for REF2 only.") +-- | @--repo@, @--old-repo@, @--new-repo@ and @--package@. +data SourceOpts = + SourceOpts (Maybe String) (Maybe String) (Maybe String) (Maybe String) + +-- | The source options. @--old-repo@ and @--new-repo@ only for commands +-- that take two refs. +sourceOpts :: Bool -> Parser SourceOpts +sourceOpts twoRefs = + parserOptionGroup "Source options:" $ + SourceOpts + <$> optional (strOption $ + long "repo" <> metavar "PATH-OR-URL" + <> help "Repository for git refs. Default: the \ + \repository of the current directory.") + <*> refRepo "old-repo" "REF1" + <*> refRepo "new-repo" "REF2" + <*> optional (strOption $ + short 'p' <> long "package" <> metavar "NAME" + <> help "Package to compare, for repositories with \ + \several packages.") -packageOpt :: Parser (Maybe String) -packageOpt = - optional $ strOption $ - short 'p' <> long "package" <> metavar "NAME" - <> help "Package to compare, for repositories with several packages." + where + + refRepo name ref + | twoRefs = + optional $ strOption $ + long name <> metavar "PATH-OR-URL" + <> help ("Repository for " ++ ref ++ " only.") + | otherwise = pure Nothing data ModuleOpts = ModuleOpts [Glob] [Glob] [Glob] moduleOpts :: Parser ModuleOpts moduleOpts = + parserOptionGroup "Module selection:" $ ModuleOpts <$> many (strOption $ long "module" <> metavar "GLOB" @@ -145,6 +151,7 @@ data BuildOpts = BuildOpts (Maybe String) [String] Bool (Maybe FilePath) Bool buildOpts :: Parser BuildOpts buildOpts = + parserOptionGroup "Build options:" $ BuildOpts <$> optional (strOption $ short 'w' <> long "with-compiler" <> metavar "GHC" @@ -163,9 +170,7 @@ buildOpts = <> help "Build git refs of the current repository by checking \ \them out in the current working tree.") -data OutputOpts = - OutputOpts ColorMode GroupBy Bool Bool Bool - (Maybe (Set Change)) (Maybe (Set Change)) Bool +data OutputOpts = OutputOpts ColorMode GroupBy Bool Bool Bool colorReader :: ReadM ColorMode colorReader = eitherReader $ \case @@ -189,6 +194,7 @@ colorOpt = outputOpts :: Parser OutputOpts outputOpts = + parserOptionGroup "Output options:" $ OutputOpts <$> colorOpt <*> option groupByReader @@ -199,7 +205,16 @@ outputOpts = <> help "Print only the module lines and the summary.") <*> switch (long "expand" <> help "Also list the symbols of added and removed modules.") - <*> changeSets parseChangeTypes + +-- | @--show@, @--hide@, @--breaking-only@ and @--fail-on@. +data FilterOpts = + FilterOpts (Maybe (Set Change)) (Maybe (Set Change)) Bool (Maybe (Set Change)) + +filterOpts :: Parser FilterOpts +filterOpts = + parserOptionGroup "Change filters:" $ + FilterOpts + <$> changeSets parseChangeTypes (long "show" <> metavar "TYPES" <> help "Show only these change types: added, removed, \ \changed, deprecated, undeprecated.") @@ -207,13 +222,11 @@ outputOpts = (long "hide" <> metavar "TYPES" <> help "Hide these change types.") <*> switch (long "breaking-only" <> help "Shorthand for --show removed,changed.") - -failOnOpt :: Parser (Maybe (Set Change)) -failOnOpt = - changeSets parseFailOn - (long "fail-on" <> metavar "TYPES" - <> help "Exit with 1 if the diff contains a change of these types. \ - \Same values as --show, plus breaking and any.") + <*> changeSets parseFailOn + (long "fail-on" <> metavar "TYPES" + <> help "Exit with 1 if the diff contains a change of \ + \these types. Same values as --show, plus \ + \breaking and any.") formatOpt :: Parser Format formatOpt = @@ -238,19 +251,18 @@ refsArg meta = many (strArgument (metavar meta)) mkOptions :: Command -> [String] - -> RepoOpts - -> Maybe String + -> SourceOpts -> ModuleOpts -> BuildOpts -> OutputOpts - -> Maybe (Set Change) + -> FilterOpts -> Format -> Options -mkOptions cmd refs (RepoOpts repo old new) pkg +mkOptions cmd refs (SourceOpts repo old new pkg) (ModuleOpts mods ignores internals) (BuildOpts compiler cabalOpts noCache workDir inPlace) - (OutputOpts color groupBy quiet collapse expand shw hide breakingOnly) - failOn fmt = + (OutputOpts color groupBy quiet collapse expand) + (FilterOpts shw hide breakingOnly failOn) fmt = Options { optCommand = cmd , optRefs = refs @@ -279,46 +291,42 @@ mkOptions cmd refs (RepoOpts repo old new) pkg } defaultOutputOpts :: ColorMode -> OutputOpts -defaultOutputOpts color = - OutputOpts color GroupByModule False False False Nothing Nothing False +defaultOutputOpts color = OutputOpts color GroupByModule False False False + +noFilterOpts :: FilterOpts +noFilterOpts = FilterOpts Nothing Nothing False Nothing diffParser :: Parser Options diffParser = - (\refs repo (old, new) -> mkOptions CmdDiff refs (RepoOpts repo old new)) + mkOptions CmdDiff <$> refsArg "[REF1 [REF2]]" - <*> repoOpt - <*> oldNewRepoOpts - <*> packageOpt + <*> sourceOpts True <*> moduleOpts <*> buildOpts <*> outputOpts - <*> failOnOpt + <*> filterOpts <*> pure FormatText checkParser :: Parser Options checkParser = - (\refs repo (old, new) pkg mods bld -> - mkOptions CmdCheck refs (RepoOpts repo old new) pkg mods bld - (defaultOutputOpts ColorNever) Nothing FormatText) + (\refs src mods bld -> + mkOptions CmdCheck refs src mods bld + (defaultOutputOpts ColorNever) noFilterOpts FormatText) <$> refsArg "[REF1 [REF2]]" - <*> repoOpt - <*> oldNewRepoOpts - <*> packageOpt + <*> sourceOpts True <*> moduleOpts <*> buildOpts apiParser :: Parser Options apiParser = - (\refs repo pkg mods bld color fmt -> - mkOptions CmdApi refs (RepoOpts repo Nothing Nothing) pkg mods bld - (defaultOutputOpts color) Nothing fmt) + (\refs src mods bld (color, fmt) -> + mkOptions CmdApi refs src mods bld + (defaultOutputOpts color) noFilterOpts fmt) <$> refsArg "[REF]" - <*> repoOpt - <*> packageOpt + <*> sourceOpts False <*> moduleOpts <*> buildOpts - <*> colorOpt - <*> formatOpt + <*> parserOptionGroup "Output options:" ((,) <$> colorOpt <*> formatOpt) usageFooter :: InfoMod a usageFooter = @@ -335,17 +343,21 @@ usageFooter = , "obtain an API." ] +-- | A command with @--help@ under "Help options:", instead of the +-- "Available options:" section that 'hsubparser' would create for it. +commandWithHelp :: String -> Parser Options -> String -> Mod CommandFields Options +commandWithHelp name p desc = + command name + (info (p <**> parserOptionGroup "Help options:" helper) + (progDesc desc <> usageFooter)) + commandParser :: Parser Options commandParser = - hsubparser $ - command "diff" - (info diffParser - (progDesc "Print the API diff between two refs." <> usageFooter)) - <> command "check" - (info checkParser - (progDesc "Print the version bump required by the diff." <> usageFooter)) - <> command "api" - (info apiParser (progDesc "Print the API of a single ref." <> usageFooter)) + subparser $ + commandWithHelp "diff" diffParser "Print the API diff between two refs." + <> commandWithHelp "check" checkParser + "Print the version bump required by the diff." + <> commandWithHelp "api" apiParser "Print the API of a single ref." parserInfo :: ParserInfo Options parserInfo = From ae4325b21455e7741b976989e6fcd6d99f38396e Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Mon, 12 Oct 2026 20:36:39 +0530 Subject: [PATCH 09/11] Rewrite the package description in README and cabal file --- README.md | 30 ++++++++++++++++++++++++++---- packdiff.cabal | 35 +++++++++++++++++++---------------- 2 files changed, 45 insertions(+), 20 deletions(-) diff --git a/README.md b/README.md index 5aa8bb5..e9d40b9 100644 --- a/README.md +++ b/README.md @@ -1,9 +1,31 @@ # packdiff -packdiff compares two versions of a Haskell package and reports the API -changes: added, removed, changed and deprecated symbols. It builds the -hoogle file of each version with `cabal haddock` and compares the two -files. Only exposed modules are compared. +packdiff tells you what changed in the public API of a Haskell package +between two versions, and which version bump the +[PVP](https://pvp.haskell.org/) requires for those changes. + +* `packdiff diff` lists the API changes module by module: added, removed, + changed, deprecated and undeprecated symbols, with the old and new + definition of each changed symbol. The summary at the end gives the + number of breaking changes. +* During development, `packdiff diff` with no arguments compares `HEAD` + with your working tree, so you can see what your uncommitted edits do to + the API before you commit. +* In CI, run `packdiff diff` on each pull request against the base + branch or the latest Hackage release. The build log then shows what the + PR changes in the API, and `--fail-on breaking` fails the build if any + change is breaking. +* `packdiff check` tells you whether a release needs a major, minor or + patch bump, and why. For example: `breaking changes between v1.2.0 + (1.2.0.0) and . (1.2.0.0): bump major (1.3.0.0)`. +* `packdiff check` returns exit code 1 if the version in the cabal file is + lower than required. You can use it to report the problem or to fail the + CI build automatically. + +The two versions can be git commits, the working tree, Hackage releases +or saved hoogle files. packdiff builds the hoogle file of each version +with `cabal haddock` and compares them. Only exposed modules are compared. +You don't need to change your package to use it. ## Usage diff --git a/packdiff.cabal b/packdiff.cabal index 1a60478..0856102 100644 --- a/packdiff.cabal +++ b/packdiff.cabal @@ -1,25 +1,28 @@ cabal-version: 2.2 name: packdiff version: 0.1.0.0 -synopsis: Find API changes between different versions of a package +synopsis: Find API changes and the required version bump between package versions description: - Packdiff compares different Git commits or Hackage versions of a package to - identify: + packdiff tells you what changed in the public API of a Haskell package + between two versions, and which version bump the PVP requires for those + changes. . - * Signature changes. - * Deprecated functions. - * Added or removed functions. - . - It helps you to: - . - * Generate API changelogs automatically. - * Generate API diff on pull requests. - * Compare new changes against published Hackage releases. - * Decide the new version of a package. - * Find breaking changes in the new release. - . - See the README for more details. + * @packdiff diff@ lists the API changes module by module: added, + removed, changed and deprecated symbols, with the old and new + definition of each changed symbol and the number of breaking changes. + * During development, compare @HEAD@ with your working tree to see what + your uncommitted edits do to the API. + * In CI, run @packdiff diff@ on each pull request to see what the PR + changes in the API, and use @--fail-on breaking@ to fail the build on + a breaking change. + * @packdiff check@ tells you whether a release needs a major, minor or + patch bump, and why. + * @packdiff check@ returns exit code 1 if the version in the cabal file + is lower than required. You can use it to report the problem or to + fail the CI build automatically. . + The two versions can be git commits, the working tree, Hackage releases + or saved hoogle files. You don't need to change your package to use it. bug-reports: https://github.com/composewell/packdiff/issues license: Apache-2.0 license-file: LICENSE From 1cbbc3bf7c3cfc02b124c8ca1c89d85a6b8dfc49 Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Mon, 12 Oct 2026 20:40:56 +0530 Subject: [PATCH 10/11] Fix CI: ignore dev files in the sdist check, use cabal.project The sdist check failed on cabal.project and sources.nix, which are not part of the source distribution. Without CABAL_PROJECT, packcheck removes cabal.project for the sdist build, but streamly-coreutils is only available through its source-repository-package. Also run hlint on cli and test. --- .github/workflows/packcheck.yml | 22 +++++++++++----------- .packcheck.ignore | 2 ++ 2 files changed, 13 insertions(+), 11 deletions(-) diff --git a/.github/workflows/packcheck.yml b/.github/workflows/packcheck.yml index cd321c3..bc3a4d4 100644 --- a/.github/workflows/packcheck.yml +++ b/.github/workflows/packcheck.yml @@ -157,16 +157,16 @@ jobs: command: cabal ghc_version: 9.12.4 # WARNING! cannot use # comments inside pack_options. - #pack_options: >- - # CABAL_PROJECT=cabal.project + pack_options: >- + CABAL_PROJECT=cabal.project - name: ci runner: ubuntu-latest command: cabal ghc_version: 9.10.3 # WARNING! cannot use # comments inside pack_options. - #pack_options: >- - # CABAL_PROJECT=cabal.project + pack_options: >- + CABAL_PROJECT=cabal.project #- name: ghc-9.10.3 # runner: ubuntu-latest @@ -182,24 +182,24 @@ jobs: command: cabal ghc_version: 9.8.4 # WARNING! cannot use # comments inside pack_options. - #pack_options: >- - # CABAL_PROJECT=cabal.project + pack_options: >- + CABAL_PROJECT=cabal.project - name: ci runner: ubuntu-latest command: cabal ghc_version: 9.6.3 # WARNING! cannot use # comments inside pack_options. - #pack_options: >- - # CABAL_PROJECT=cabal.project + pack_options: >- + CABAL_PROJECT=cabal.project - name: ci runner: windows-latest command: cabal ghc_version: 9.12.4 # WARNING! cannot use # comments inside pack_options. - #pack_options: >- - # CABAL_PROJECT=cabal.project + pack_options: >- + CABAL_PROJECT=cabal.project - name: ci runner: ubuntu-latest @@ -208,7 +208,7 @@ jobs: pack_options: >- HLINT_VERSION=3.6.1 HLINT_OPTIONS="lint" - HLINT_TARGETS="src" + HLINT_TARGETS="src cli test" #- name: docspec # runner: ubuntu-latest diff --git a/.packcheck.ignore b/.packcheck.ignore index b233951..13c12d8 100644 --- a/.packcheck.ignore +++ b/.packcheck.ignore @@ -4,3 +4,5 @@ cabal.project.Werror flake.lock flake.nix +cabal.project +sources.nix From 64926db44181230b46e6abd47188410b71c52d92 Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Mon, 12 Oct 2026 21:14:12 +0530 Subject: [PATCH 11/11] Update the packcheck commit and the hlint version in CI --- .github/workflows/packcheck.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/workflows/packcheck.yml b/.github/workflows/packcheck.yml index bc3a4d4..a0e6295 100644 --- a/.github/workflows/packcheck.yml +++ b/.github/workflows/packcheck.yml @@ -90,7 +90,7 @@ jobs: # If you have not committed packcheck.sh in your repo at PACKCHECK # then it is automatically pulled from this URL. PACKCHECK_GITHUB_URL: "https://raw.githubusercontent.com/composewell/packcheck" - PACKCHECK_GITHUB_COMMIT: "3d3c94bf48f18a99271d509c1f1702d15824b1f0" + PACKCHECK_GITHUB_COMMIT: "24ce59169b3e1a486963201671bceaeed54e9e65" # ------------------------------------------------------------------------ # Final build variables @@ -206,7 +206,7 @@ jobs: command: hlint # WARNING! cannot use # comments inside pack_options. pack_options: >- - HLINT_VERSION=3.6.1 + HLINT_VERSION=3.10 HLINT_OPTIONS="lint" HLINT_TARGETS="src cli test"