diff --git a/.envrc b/.envrc new file mode 100644 index 0000000..80377dd --- /dev/null +++ b/.envrc @@ -0,0 +1 @@ +use flake -Lv diff --git a/.github/workflows/test-flake.yml b/.github/workflows/test-flake.yml new file mode 100644 index 0000000..fcc5e57 --- /dev/null +++ b/.github/workflows/test-flake.yml @@ -0,0 +1,16 @@ +name: "Check Flake" +on: + workflow_dispatch: + pull_request: + push: +jobs: + install-nix: + runs-on: ubuntu-latest + steps: + - uses: actions/checkout@v3 + - uses: cachix/install-nix-action@v22 + with: + github_access_token: ${{ secrets.GITHUB_TOKEN }} + - run: nix flake check -Lv --allow-import-from-derivation --fallback --accept-flake-config + - run: nix build .#transitive-anns -Lv --fallback --accept-flake-config + - run: nix build .#ghc92-transitive-anns -Lv --fallback --accept-flake-config diff --git a/.github/workflows/update-flake-lock.yml b/.github/workflows/update-flake-lock.yml new file mode 100644 index 0000000..9dfc825 --- /dev/null +++ b/.github/workflows/update-flake-lock.yml @@ -0,0 +1,21 @@ +name: update-flake-lock +on: + workflow_dispatch: # allows manual triggering + schedule: + - cron: '0 0 * * 0' # runs weekly on Sunday at 00:00 + +jobs: + lockfile: + runs-on: ubuntu-latest + steps: + - name: Checkout repository + uses: actions/checkout@v3 + - name: Install Nix + uses: DeterminateSystems/nix-installer-action@main + - name: Update flake.lock + uses: DeterminateSystems/update-flake-lock@main + with: + pr-title: "Update flake.lock" # Title of PR to be created + pr-labels: | # Labels to be set on the PR + dependencies + automated diff --git a/.gitignore b/.gitignore index c368d45..377d3a4 100644 --- a/.gitignore +++ b/.gitignore @@ -1,2 +1,6 @@ .stack-work/ -*~ \ No newline at end of file +*~ +.direnv +dist* +result* +.pre-commit-config.yaml diff --git a/.stylish-haskell.yaml b/.stylish-haskell.yaml new file mode 100644 index 0000000..e170902 --- /dev/null +++ b/.stylish-haskell.yaml @@ -0,0 +1,480 @@ +# stylish-haskell configuration file +# ================================== + +# The stylish-haskell tool is mainly configured by specifying steps. These steps +# are a list, so they have an order, and one specific step may appear more than +# once (if needed). Each file is processed by these steps in the given order. +steps: + # Convert some ASCII sequences to their Unicode equivalents. This is disabled + # by default. + # - unicode_syntax: + # # In order to make this work, we also need to insert the UnicodeSyntax + # # language pragma. If this flag is set to true, we insert it when it's + # # not already present. You may want to disable it if you configure + # # language extensions using some other method than pragmas. Default: + # # true. + # add_language_pragma: true + + # Format module header + # + # Currently, this option is not configurable and will format all exports and + # module declarations to minimize diffs + # + # - module_header: + # # How many spaces use for indentation in the module header. + # indent: 4 + # + # # Should export lists be sorted? Sorting is only performed within the + # # export section, as delineated by Haddock comments. + # sort: true + # + # # See `separate_lists` for the `imports` step. + # separate_lists: true + # + # # When to break the "where". + # # Possible values: + # # - exports: only break when there is an explicit export list. + # # - single: only break when the export list counts more than one export. + # # - inline: only break when the export list is too long. This is + # # determined by the `columns` setting. Not applicable when the export + # # list contains comments as newlines will be required. + # # - always: always break before the "where". + # break_where: exports + # + # # Where to put open bracket + # # Possible values: + # # - same_line: put open bracket on the same line as the module name, before the + # # comment of the module + # # - next_line: put open bracket on the next line, after module comment + # open_bracket: next_line + + # Format record definitions. This is disabled by default. + # + # You can control the layout of record fields. The only rules that can't be configured + # are these: + # + # - "|" is always aligned with "=" + # - "," in fields is always aligned with "{" + # - "}" is likewise always aligned with "{" + # + # - records: + # # How to format equals sign between type constructor and data constructor. + # # Possible values: + # # - "same_line" -- leave "=" AND data constructor on the same line as the type constructor. + # # - "indent N" -- insert a new line and N spaces from the beginning of the next line. + # equals: "indent 2" + # + # # How to format first field of each record constructor. + # # Possible values: + # # - "same_line" -- "{" and first field goes on the same line as the data constructor. + # # - "indent N" -- insert a new line and N spaces from the beginning of the data constructor + # first_field: "indent 2" + # + # # How many spaces to insert between the column with "," and the beginning of the comment in the next line. + # field_comment: 2 + # + # # How many spaces to insert before "deriving" clause. Deriving clauses are always on separate lines. + # deriving: 2 + # + # # How many spaces to insert before "via" clause counted from indentation of deriving clause + # # Possible values: + # # - "same_line" -- "via" part goes on the same line as "deriving" keyword. + # # - "indent N" -- insert a new line and N spaces from the beginning of "deriving" keyword. + # via: "indent 2" + # + # # Sort typeclass names in the "deriving" list alphabetically. + # sort_deriving: true + # + # # Whether or not to break enums onto several lines + # # + # # Default: false + # break_enums: false + # + # # Whether or not to break single constructor data types before `=` sign + # # + # # Default: true + # break_single_constructors: true + # + # # Whether or not to curry constraints on function. + # # + # # E.g: @allValues :: Enum a => Bounded a => Proxy a -> [a]@ + # # + # # Instead of @allValues :: (Enum a, Bounded a) => Proxy a -> [a]@ + # # + # # Default: false + # curried_context: false + + # Align the right hand side of some elements. This is quite conservative + # and only applies to statements where each element occupies a single + # line. + # Possible values: + # - always - Always align statements. + # - adjacent - Align statements that are on adjacent lines in groups. + # - never - Never align statements. + # All default to always. + - simple_align: + cases: always + top_level_patterns: always + records: always + multi_way_if: always + + # Import cleanup + - imports: + # There are different ways we can align names and lists. + # + # - global: Align the import names and import list throughout the entire + # file. + # + # - file: Like global, but don't add padding when there are no qualified + # imports in the file. + # + # - group: Only align the imports per group (a group is formed by adjacent + # import lines). + # + # - none: Do not perform any alignment. + # + # Default: global. + align: global + + # The following options affect only import list alignment. + # + # List align has following options: + # + # - after_alias: Import list is aligned with end of import including + # 'as' and 'hiding' keywords. + # + # > import qualified Data.List as List (concat, foldl, foldr, head, + # > init, last, length) + # + # - with_alias: Import list is aligned with start of alias or hiding. + # + # > import qualified Data.List as List (concat, foldl, foldr, head, + # > init, last, length) + # + # - with_module_name: Import list is aligned `list_padding` spaces after + # the module name. + # + # > import qualified Data.List as List (concat, foldl, foldr, head, + # init, last, length) + # + # This is mainly intended for use with `pad_module_names: false`. + # + # > import qualified Data.List as List (concat, foldl, foldr, head, + # init, last, length, scanl, scanr, take, drop, + # sort, nub) + # + # - new_line: Import list starts always on new line. + # + # > import qualified Data.List as List + # > (concat, foldl, foldr, head, init, last, length) + # + # - repeat: Repeat the module name to align the import list. + # + # > import qualified Data.List as List (concat, foldl, foldr, head) + # > import qualified Data.List as List (init, last, length) + # + # Default: after_alias + list_align: after_alias + + # Right-pad the module names to align imports in a group: + # + # - true: a little more readable + # + # > import qualified Data.List as List (concat, foldl, foldr, + # > init, last, length) + # > import qualified Data.List.Extra as List (concat, foldl, foldr, + # > init, last, length) + # + # - false: diff-safe + # + # > import qualified Data.List as List (concat, foldl, foldr, init, + # > last, length) + # > import qualified Data.List.Extra as List (concat, foldl, foldr, + # > init, last, length) + # + # Default: true + pad_module_names: true + + # Long list align style takes effect when import is too long. This is + # determined by 'columns' setting. + # + # - inline: This option will put as much specs on same line as possible. + # + # - new_line: Import list will start on new line. + # + # - new_line_multiline: Import list will start on new line when it's + # short enough to fit to single line. Otherwise it'll be multiline. + # + # - multiline: One line per import list entry. + # Type with constructor list acts like single import. + # + # > import qualified Data.Map as M + # > ( empty + # > , singleton + # > , ... + # > , delete + # > ) + # + # Default: inline + long_list_align: inline + + # Align empty list (importing instances) + # + # Empty list align has following options + # + # - inherit: inherit list_align setting + # + # - right_after: () is right after the module name: + # + # > import Vector.Instances () + # + # Default: inherit + empty_list_align: inherit + + # List padding determines indentation of import list on lines after import. + # This option affects 'long_list_align'. + # + # - : constant value + # + # - module_name: align under start of module name. + # Useful for 'file' and 'group' align settings. + # + # Default: 4 + list_padding: 4 + + # Separate lists option affects formatting of import list for type + # or class. The only difference is single space between type and list + # of constructors, selectors and class functions. + # + # - true: There is single space between Foldable type and list of it's + # functions. + # + # > import Data.Foldable (Foldable (fold, foldl, foldMap)) + # + # - false: There is no space between Foldable type and list of it's + # functions. + # + # > import Data.Foldable (Foldable(fold, foldl, foldMap)) + # + # Default: true + separate_lists: true + + # Space surround option affects formatting of import lists on a single + # line. The only difference is single space after the initial + # parenthesis and a single space before the terminal parenthesis. + # + # - true: There is single space associated with the enclosing + # parenthesis. + # + # > import Data.Foo ( foo ) + # + # - false: There is no space associated with the enclosing parenthesis + # + # > import Data.Foo (foo) + # + # Default: false + space_surround: false + + # Post qualify option moves any qualifies found in import declarations + # to the end of the declaration. This also adjust padding for any + # unqualified import declarations. + # + # - true: Qualified as is moved to the end of the + # declaration. + # + # > import Data.Bar + # > import Data.Foo qualified as F + # + # - false: Qualified remains in the default location and unqualified + # imports are padded to align with qualified imports. + # + # > import Data.Bar + # > import qualified Data.Foo as F + # + # Default: false + post_qualify: false + + # Automatically group imports based on their module names, with + # a blank line separating each group. Groups are ordered in + # alphabetical order. + # + # By default, this groups by the first part of each module's + # name (Control.* will be grouped together, Data.*... etc), but + # this can be configured with the group_patterns setting. + # + # When enabled, this rewrites existing blank lines and groups. + # + # - true: Group imports by the first part of the module name. + # + # > import Control.Applicative + # > import Control.Monad + # > import Control.Monad.MonadError + # > + # > import Data.Functor + # + # - false: Keep import groups as-is (still sorting and + # formatting the imports within each group) + # + # > import Control.Monad + # > import Data.Functor + # > + # > import Control.Applicative + # > import Control.Monad.MonadError + # + # Default: false + group_imports: false + + # A list of rules specifying how to group modules and how to + # order the groups. + # + # Each rule has a match field; the rule only applies to module + # names matched by this pattern. Patterns are POSIX extended + # regular expressions; see the documentation of Text.Regex.TDFA + # for details: + # https://hackage.haskell.org/package/regex-tdfa-1.3.1.2/docs/Text-Regex-TDFA.html + # + # Rules are processed in order, so only the *first* rule that + # matches a specific module will apply. Any module names that do + # not match a single rule will be put into a single group at the + # end of the import block. + # + # Example: group MyApp modules first, with everything else in + # one group at the end. + # + # group_rules: + # - match: "^MyApp\\>" + # + # > import MyApp + # > import MyApp.Foo + # > + # > import Control.Monad + # > import MyApps + # > import Test.MyApp + # + # A rule can also optionally have a sub_group pattern. Imports + # that match the rule will be broken up into further groups by + # the part of the module name matched by the sub_group pattern. + # + # Example: group MyApp modules first, then everything else + # sub-grouped by the first part of the module name. + # + # group_rules: + # - match: "^MyApp\\>" + # - match: "." + # sub_group: "^[^.]+" + # + # > import MyApp + # > import MyApp.Foo + # > + # > import Control.Applicative + # > import Control.Monad + # > + # > import Data.Map + # + # A pattern only needs to match part of the module name, which + # could be in the middle. You can use ^pattern to anchor to the + # beginning of the module name, pattern$ to anchor to the end + # and ^pattern$ to force a full match. Example: + # + # - "Test\\." would match "Test.Foo" and "Foo.Test.Lib" + # - "^Test\\." would match "Test.Foo" but not "Foo.Test.Lib" + # - "\\.Test$" would match "Foo.Test" but not "Foo.Test.Lib" + # - "^Test$" would *only* match "Test" + # + # You can use \\< and \\> to anchor against the beginning and + # end of words, respectively. For example: + # + # - "^Test\\." would match "Test.Foo" but not "Test" or "Tests" + # - "^Test\\>" would match "Test.Foo" and "Test", but not + # "Tests" + # + # The default is a single rule that matches everything and + # sub-groups based on the first component of the module name. + # + # Default: [{ "match" : ".*", "sub_group": "^[^.]+" }] + group_rules: + - match: ".*" + sub_group: "^[^.]+" + + # Language pragmas + - language_pragmas: + # We can generate different styles of language pragma lists. + # + # - vertical: Vertical-spaced language pragmas, one per line. + # + # - compact: A more compact style. + # + # - compact_line: Similar to compact, but wrap each line with + # `{-# LANGUAGE #-}'. + # + # - vertical_compact: Similar to vertical, but use only one language pragma. + # + # Default: vertical. + style: vertical + + # Align affects alignment of closing pragma brackets. + # + # - true: Brackets are aligned in same column. + # + # - false: Brackets are not aligned together. There is only one space + # between actual import and closing bracket. + # + # Default: true + align: true + + # stylish-haskell can detect redundancy of some language pragmas. If this + # is set to true, it will remove those redundant pragmas. Default: true. + remove_redundant: true + + # Language prefix to be used for pragma declaration, this allows you to + # use other options non case-sensitive like "language" or "Language". + # If a non correct String is provided, it will default to: LANGUAGE. + language_prefix: LANGUAGE + + # Replace tabs by spaces. This is disabled by default. + # - tabs: + # # Number of spaces to use for each tab. Default: 8, as specified by the + # # Haskell report. + # spaces: 8 + + # Remove trailing whitespace + - trailing_whitespace: {} + + # Squash multiple spaces between the left and right hand sides of some + # elements into single spaces. Basically, this undoes the effect of + # simple_align but is a bit less conservative. + # - squash: {} + +# A common setting is the number of columns (parts of) code will be wrapped +# to. Different steps take this into account. +# +# Set this to null to disable all line wrapping. +# +# Default: 80. +columns: 80 + +# By default, line endings are converted according to the OS. You can override +# preferred format here. +# +# - native: Native newline format. CRLF on Windows, LF on other OSes. +# +# - lf: Convert to LF ("\n"). +# +# - crlf: Convert to CRLF ("\r\n"). +# +# Default: native. +newline: native + +# Sometimes, language extensions are specified in a cabal file or from the +# command line instead of using language pragmas in the file. stylish-haskell +# needs to be aware of these, so it can parse the file correctly. +# +# No language extensions are enabled by default. +language_extensions: + - CPP + +# Attempt to find the cabal file in ancestors of the current directory, and +# parse options (currently only language extensions) from that. +# +# Default: true +cabal: true diff --git a/Setup.hs b/Setup.hs index 9a994af..4467109 100644 --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,2 @@ -import Distribution.Simple +import Distribution.Simple main = defaultMain diff --git a/flake.lock b/flake.lock new file mode 100644 index 0000000..3eff135 --- /dev/null +++ b/flake.lock @@ -0,0 +1,205 @@ +{ + "nodes": { + "flake-compat": { + "flake": false, + "locked": { + "lastModified": 1673956053, + "narHash": "sha256-4gtG9iQuiKITOjNQQeQIpoIB6b16fm+504Ch3sNKLd8=", + "owner": "edolstra", + "repo": "flake-compat", + "rev": "35bb57c0c8d8b62bbfd284272c928ceb64ddbde9", + "type": "github" + }, + "original": { + "owner": "edolstra", + "repo": "flake-compat", + "type": "github" + } + }, + "flake-utils": { + "inputs": { + "systems": "systems" + }, + "locked": { + "lastModified": 1685518550, + "narHash": "sha256-o2d0KcvaXzTrPRIo0kOLV0/QXHhDQ5DTi+OxcjO8xqY=", + "owner": "numtide", + "repo": "flake-utils", + "rev": "a1720a10a6cfe8234c0e93907ffe81be440f4cef", + "type": "github" + }, + "original": { + "owner": "numtide", + "repo": "flake-utils", + "type": "github" + } + }, + "gitignore": { + "inputs": { + "nixpkgs": [ + "pre-commit-hooks", + "nixpkgs" + ] + }, + "locked": { + "lastModified": 1660459072, + "narHash": "sha256-8DFJjXG8zqoONA1vXtgeKXy68KdJL5UaXR8NtVMUbx8=", + "owner": "hercules-ci", + "repo": "gitignore.nix", + "rev": "a20de23b925fd8264fd7fad6454652e142fd7f73", + "type": "github" + }, + "original": { + "owner": "hercules-ci", + "repo": "gitignore.nix", + "type": "github" + } + }, + "haskell-flake": { + "locked": { + "lastModified": 1698070134, + "narHash": "sha256-wJq3FmAcZ09FbkghNynvujhmxTAXHJLNWwX9G5oYi8M=", + "owner": "srid", + "repo": "haskell-flake", + "rev": "f1380932a7b6ec360020acb87dd39331ebabb04c", + "type": "github" + }, + "original": { + "owner": "srid", + "repo": "haskell-flake", + "type": "github" + } + }, + "nixpkgs": { + "locked": { + "lastModified": 1697915759, + "narHash": "sha256-WyMj5jGcecD+KC8gEs+wFth1J1wjisZf8kVZH13f1Zo=", + "owner": "nixos", + "repo": "nixpkgs", + "rev": "51d906d2341c9e866e48c2efcaac0f2d70bfd43e", + "type": "github" + }, + "original": { + "owner": "nixos", + "ref": "nixpkgs-unstable", + "repo": "nixpkgs", + "type": "github" + } + }, + "nixpkgs-lib": { + "locked": { + "dir": "lib", + "lastModified": 1696019113, + "narHash": "sha256-X3+DKYWJm93DRSdC5M6K5hLqzSya9BjibtBsuARoPco=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "f5892ddac112a1e9b3612c39af1b72987ee5783a", + "type": "github" + }, + "original": { + "dir": "lib", + "owner": "NixOS", + "ref": "nixos-unstable", + "repo": "nixpkgs", + "type": "github" + } + }, + "nixpkgs-stable": { + "locked": { + "lastModified": 1685801374, + "narHash": "sha256-otaSUoFEMM+LjBI1XL/xGB5ao6IwnZOXc47qhIgJe8U=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "c37ca420157f4abc31e26f436c1145f8951ff373", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixos-23.05", + "repo": "nixpkgs", + "type": "github" + } + }, + "nixpkgs_2": { + "locked": { + "lastModified": 1689261696, + "narHash": "sha256-LzfUtFs9MQRvIoQ3MfgSuipBVMXslMPH/vZ+nM40LkA=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "df1eee2aa65052a18121ed4971081576b25d6b5c", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixpkgs-unstable", + "repo": "nixpkgs", + "type": "github" + } + }, + "parts": { + "inputs": { + "nixpkgs-lib": "nixpkgs-lib" + }, + "locked": { + "lastModified": 1696343447, + "narHash": "sha256-B2xAZKLkkeRFG5XcHHSXXcP7To9Xzr59KXeZiRf4vdQ=", + "owner": "hercules-ci", + "repo": "flake-parts", + "rev": "c9afaba3dfa4085dbd2ccb38dfade5141e33d9d4", + "type": "github" + }, + "original": { + "owner": "hercules-ci", + "repo": "flake-parts", + "type": "github" + } + }, + "pre-commit-hooks": { + "inputs": { + "flake-compat": "flake-compat", + "flake-utils": "flake-utils", + "gitignore": "gitignore", + "nixpkgs": "nixpkgs_2", + "nixpkgs-stable": "nixpkgs-stable" + }, + "locked": { + "lastModified": 1697746376, + "narHash": "sha256-gu77VkgdfaHgNCVufeb6WP9oqFLjwK4jHcoPZmBVF3E=", + "owner": "cachix", + "repo": "pre-commit-hooks.nix", + "rev": "8cc349bfd082da8782b989cad2158c9ad5bd70fd", + "type": "github" + }, + "original": { + "owner": "cachix", + "repo": "pre-commit-hooks.nix", + "type": "github" + } + }, + "root": { + "inputs": { + "haskell-flake": "haskell-flake", + "nixpkgs": "nixpkgs", + "parts": "parts", + "pre-commit-hooks": "pre-commit-hooks" + } + }, + "systems": { + "locked": { + "lastModified": 1681028828, + "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=", + "owner": "nix-systems", + "repo": "default", + "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e", + "type": "github" + }, + "original": { + "owner": "nix-systems", + "repo": "default", + "type": "github" + } + } + }, + "root": "root", + "version": 7 +} diff --git a/flake.nix b/flake.nix new file mode 100644 index 0000000..b5b1874 --- /dev/null +++ b/flake.nix @@ -0,0 +1,49 @@ +{ + nixConfig.allow-import-from-derivation = true; + inputs = { + nixpkgs.url = "github:nixos/nixpkgs/nixpkgs-unstable"; + parts.url = "github:hercules-ci/flake-parts"; + haskell-flake.url = "github:srid/haskell-flake"; + pre-commit-hooks.url = "github:cachix/pre-commit-hooks.nix"; + }; + outputs = inputs: + inputs.parts.lib.mkFlake {inherit inputs;} { + systems = ["x86_64-linux"]; + imports = [ + inputs.haskell-flake.flakeModule + inputs.pre-commit-hooks.flakeModule + ]; + + perSystem = { + config, + pkgs, + ... + }: { + pre-commit = { + check.enable = true; + settings.hooks = { + cabal-fmt.enable = true; + hlint.enable = true; + + alejandra.enable = true; + statix.enable = true; + deadnix.enable = true; + }; + }; + + haskellProjects.ghc92 = { + packages = {}; + settings = {}; + basePackages = pkgs.haskell.packages.ghc92; + devShell.mkShellArgs.shellHook = config.pre-commit.installationScript; + }; + + haskellProjects.default = { + packages = {}; + settings = {}; + basePackages = pkgs.haskell.packages.ghc94; + devShell.mkShellArgs.shellHook = config.pre-commit.installationScript; + }; + }; + }; +} diff --git a/hie.yaml b/hie.yaml index 86de294..815e986 100644 --- a/hie.yaml +++ b/hie.yaml @@ -1,2 +1,7 @@ cradle: - stack: {} + cabal: + - path: "src" + component: "lib:transitive-anns" + + - path: "test" + component: "transitive-anns:test:test" diff --git a/src/TransitiveAnns/Plugin.hs b/src/TransitiveAnns/Plugin.hs index 444fd7c..a8184ef 100644 --- a/src/TransitiveAnns/Plugin.hs +++ b/src/TransitiveAnns/Plugin.hs @@ -1,27 +1,29 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE CPP #-} module TransitiveAnns.Plugin where import Data.Data -import Data.Foldable (fold) -import Data.IORef (newIORef, modifyIORef', writeIORef, readIORef) -import qualified Data.Map as M -import Data.Maybe (mapMaybe) -import qualified Data.Set as S -import Data.Traversable (for) -import GHC (Class, GhcTc, LHsBindsLR) -import GHC.Core.Class (classTyCon) -import GHC.Data.Bag (bagToList) -import GHC.Plugins hiding (TcPlugin, (<>), empty) +import Data.Foldable (fold) +import Data.IORef (modifyIORef', newIORef, + readIORef, writeIORef) +import qualified Data.Map as M +import Data.Maybe (mapMaybe) +import qualified Data.Set as S +import Data.Traversable (for) +import GHC (Class, GhcTc, LHsBindsLR) +import GHC.Core.Class (classTyCon) +import GHC.Data.Bag (bagToList) +import GHC.Plugins hiding (TcPlugin, empty, + (<>)) import GHC.Tc.Types.Constraint -import GHC.Tc.Types.Evidence (EvTerm(EvExpr)) +import GHC.Tc.Types.Evidence (EvTerm (EvExpr)) import GHC.Tc.Utils.Monad -import GHC.Tc.Utils.TcMType (newWanted) -import System.IO.Unsafe (unsafePerformIO) +import GHC.Tc.Utils.TcMType (newWanted) +import System.IO.Unsafe (unsafePerformIO) import TransitiveAnns.Plugin.Annotations import TransitiveAnns.Plugin.Core import TransitiveAnns.Plugin.Utils -import qualified TransitiveAnns.Types as TA +import qualified TransitiveAnns.Types as TA ------------------------------------------------------------------------------ @@ -36,6 +38,9 @@ plugin = defaultPlugin lookupTransitiveAnnsData , tcPluginSolve = solve , tcPluginStop = const $ pure () +#if MIN_VERSION_GLASGOW_HASKELL(9,4,0,0) + , tcPluginRewrite = const emptyUFM +#endif } , pluginRecompile = purePlugin } @@ -89,22 +94,22 @@ transitiveAnnEnv annenv binds = findWanted :: Class -> Ct -> Maybe Ct findWanted c ct = do let p = ctev_pred $ cc_ev ct - case splitTyConApp_maybe p of - Just (x, _) -> - case x == classTyCon c of - True -> Just ct - False -> Nothing - _ -> Nothing + splitTyConApp_maybe p >>= \(x, _) -> + if x == classTyCon c then Just ct else Nothing ------------------------------------------------------------------------------ -- | The entry-point to the TC plugin. This is responsible for solving --- AddAnnotation, KnownAnnotation and ToHasAnnotations nstraints +-- AddAnnotation, KnownAnnotation and ToHasAnnotations constraints solve :: TransitiveAnnsData -> TcPluginSolver +#if MIN_VERSION_GLASGOW_HASKELL(9,4,0,0) +solve tad _ gs ws = do +#else solve tad gs ds ws' = do -- Our to-solve wanteds might have been derived, so add the deriveds to the -- wanteds. let ws = ws' <> ds +#endif -- Because of our skolem trick, GHC doesn't recognize that we'd like to solve -- a wanted with a given. This function only attemps to solve the class if -- there are no givens for the class in scope. @@ -117,8 +122,7 @@ solve tad gs ds ws' = do -- Try to solve the three classes adds <- over solveAddAnn tad_add_ann - (has_ev, has_new) - <- fmap unzip $ over solveToHasAnns tad_to_has_ann + (has_ev, has_new) <- unzip <$> over solveToHasAnns tad_to_has_ann knowns <- over solveKnownAnns tad_knownanns let res = concat $ adds <> knowns pure $ TcPluginOk (res <> has_ev) $ concat has_new @@ -217,8 +221,7 @@ solveAddAnn tad to_add $ toSerialized serializeWithData ann unsafeTcPluginTcM $ liftIO - $ modifyIORef' unsafeAnnsToAddRef - $ (annx :) + $ modifyIORef' unsafeAnnsToAddRef (annx :) pure $ pure (EvExpr $ mkAddAnnDict tad ann, to_add) | otherwise = pure [] diff --git a/src/TransitiveAnns/Plugin/Annotations.hs b/src/TransitiveAnns/Plugin/Annotations.hs index 796e1c5..1e7b0ab 100644 --- a/src/TransitiveAnns/Plugin/Annotations.hs +++ b/src/TransitiveAnns/Plugin/Annotations.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE ViewPatterns #-} module TransitiveAnns.Plugin.Annotations @@ -9,17 +10,17 @@ module TransitiveAnns.Plugin.Annotations , hsBinds ) where -import Data.Data hiding (TyCon) -import Data.Functor ((<&>)) -import Data.Generics (everything, mkQ) -import Data.Map (Map) -import qualified Data.Map as M -import Data.Map.Monoidal (MonoidalMap) -import qualified Data.Map.Monoidal as MM -import Data.Set (Set) -import qualified Data.Set as S -import GHC.Hs hiding (anns) -import GHC.Plugins hiding (TcPlugin, (<>), empty) +import Data.Data hiding (TyCon) +import Data.Functor ((<&>)) +import Data.Generics (everything, mkQ) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Map.Monoidal (MonoidalMap) +import qualified Data.Map.Monoidal as MM +import Data.Set (Set) +import qualified Data.Set as S +import GHC.Hs hiding (anns) +import GHC.Plugins hiding (TcPlugin, empty, (<>)) import qualified TransitiveAnns.Types as TA @@ -29,8 +30,13 @@ hsBinds :: HsBindLR GhcTc GhcTc -> Maybe (Var, Set Var) hsBinds (FunBind _ (L _ gl) mg _) = Just (gl, getVars mg) hsBinds PatBind{} = Nothing hsBinds VarBind{} = Nothing -hsBinds (AbsBinds _ _ _ [(ABE _ nm _ _ _)] _ bag _) = Just (nm, getVars bag) -hsBinds (AbsBinds _ _ _ _ _ _ _) = Nothing +#if MIN_VERSION_GLASGOW_HASKELL(9,4,0,0) +hsBinds (XHsBindsLR (AbsBinds _ _ [ABE nm _ _ _] _ bag _)) = Just (nm, getVars bag) +hsBinds (XHsBindsLR (AbsBinds {})) = Nothing +#else +hsBinds (AbsBinds _ _ _ [ABE _ nm _ _ _] _ bag _) = Just (nm, getVars bag) +hsBinds AbsBinds {} = Nothing +#endif hsBinds PatSynBind{} = Nothing @@ -38,7 +44,7 @@ hsBinds PatSynBind{} = Nothing -- | Apply a function over all binds, accumulating the results into a map. forBinds :: Ord b => (Expr b -> r) -> Bind b -> Map b r forBinds f (NonRec b ex) = M.singleton b $ f ex -forBinds f (Rec x0) = foldMap (\(b, e) -> M.singleton b $ f e) x0 +forBinds f (Rec x0) = foldMap (\(b, e) -> M.singleton b $ f e) x0 ------------------------------------------------------------------------------ diff --git a/src/TransitiveAnns/Plugin/Core.hs b/src/TransitiveAnns/Plugin/Core.hs index fc6fe2a..e121197 100644 --- a/src/TransitiveAnns/Plugin/Core.hs +++ b/src/TransitiveAnns/Plugin/Core.hs @@ -1,10 +1,10 @@ module TransitiveAnns.Plugin.Core where -import Data.String (fromString) -import GHC.Core.Class (Class) -import GHC.Plugins hiding (TcPlugin, (<>), empty) +import Data.String (fromString) +import GHC.Core.Class (Class) +import GHC.Plugins hiding (TcPlugin, empty, (<>)) import TransitiveAnns.Plugin.Utils -import qualified TransitiveAnns.Types as TA +import qualified TransitiveAnns.Types as TA ------------------------------------------------------------------------------ -- | Make a string literal in core. Leads to less-efficient core than the diff --git a/src/TransitiveAnns/Plugin/Utils.hs b/src/TransitiveAnns/Plugin/Utils.hs index 4066b21..e83519e 100644 --- a/src/TransitiveAnns/Plugin/Utils.hs +++ b/src/TransitiveAnns/Plugin/Utils.hs @@ -1,5 +1,6 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE CPP #-} module TransitiveAnns.Plugin.Utils where @@ -21,6 +22,9 @@ import GHC.Tc.Plugin (findImportedModule, lookupOrig, tcLookupClass, t import GHC.Tc.Types.Constraint import GHC.Tc.Utils.Monad import qualified TransitiveAnns.Types as TA +#if MIN_VERSION_GLASGOW_HASKELL(9,4,0,0) +import GHC.Utils.Trace (pprTrace) +#endif ------------------------------------------------------------------------------ @@ -40,7 +44,11 @@ data TransitiveAnnsData = TransitiveAnnsData lookupTransitiveAnnsData :: TcPluginM TransitiveAnnsData lookupTransitiveAnnsData = do Found _ tys_mod +#if MIN_VERSION_GLASGOW_HASKELL(9,4,0,0) + <- findImportedModule (mkModuleName "TransitiveAnns.Types") NoPkgQual +#else <- findImportedModule (mkModuleName "TransitiveAnns.Types") Nothing +#endif known <- lookupOrig tys_mod $ mkTcOcc "KnownAnnotations" add_ann <- lookupOrig tys_mod $ mkTcOcc "AddAnnotation" to_has_ann <- lookupOrig tys_mod $ mkTcOcc "ToHasAnnotations" @@ -85,8 +93,8 @@ parsePromotedAnn tad ty = do guard $ dataConTyCon loc_dc == tad_loc_tc tad let loc = toEnum $ dataConTag loc_dc - 1 - api <- fmap unpackFS $ isStrLitTy api_ty - method <- fmap unpackFS $ isStrLitTy method_ty + api <- unpackFS <$> isStrLitTy api_ty + method <- unpackFS <$> isStrLitTy method_ty pure $ TA.Annotation loc api method @@ -122,7 +130,11 @@ getDec bs ss = listToMaybe $ do L _ b <- bagToList bs everything (<>) (mkQ [] $ \case L (SrcSpanAnn _ (RealSrcSpan ss' _)) +#if MIN_VERSION_GLASGOW_HASKELL(9,4,0,0) + (XHsBindsLR (AbsBinds _ _ [ABE poly _ _ _] _ (bagToList -> [L _ FunBind{}]) _)) +#else (AbsBinds _ _ _ [ABE _ poly _ _ _] _ (bagToList -> [L _ FunBind{}]) _) +#endif | containsSpan ss' ss -> pure (poly, b) L (SrcSpanAnn _ (RealSrcSpan ss' _)) (FunBind {fun_id = L _ n'}) | containsSpan ss' ss -> pure (n', b) diff --git a/test/InstanceSpec.hs b/test/InstanceSpec.hs index 18919da..09b31ba 100644 --- a/test/InstanceSpec.hs +++ b/test/InstanceSpec.hs @@ -2,12 +2,12 @@ module InstanceSpec where -import qualified Data.Set as S -import Data.Set (Set) -import TransitiveAnns.Types -import Test.Hspec -import GHC.TypeLits -import InstanceVia +import Data.Set (Set) +import qualified Data.Set as S +import GHC.TypeLits +import InstanceVia +import Test.Hspec +import TransitiveAnns.Types test :: forall (comp :: Symbol) (name :: Symbol) x. AddAnnotation 'Remote comp name x => Int diff --git a/test/LetBindingSpec.hs b/test/LetBindingSpec.hs index 4bc8ede..6f2d6f3 100644 --- a/test/LetBindingSpec.hs +++ b/test/LetBindingSpec.hs @@ -4,10 +4,10 @@ module LetBindingSpec where -import GHC.TypeLits -import qualified Data.Set as S -import TransitiveAnns.Types -import Test.Hspec +import qualified Data.Set as S +import GHC.TypeLits +import Test.Hspec +import TransitiveAnns.Types fedClient :: forall (api :: Symbol) (name :: Symbol) x @@ -16,6 +16,7 @@ fedClient -> Int fedClient _ = 5 +{-# ANN notifyUserDeleted "HLint: ignore Evaluate" #-} notifyUserDeleted :: String -> () notifyUserDeleted str = do let b = null str diff --git a/test/MultipleSpec.hs b/test/MultipleSpec.hs index 8aabce7..1916c72 100644 --- a/test/MultipleSpec.hs +++ b/test/MultipleSpec.hs @@ -1,10 +1,10 @@ module MultipleSpec where -import qualified Data.Set as S -import Data.Set (Set) -import TransitiveAnns.Types -import Test.Hspec -import MultipleVia +import Data.Set (Set) +import qualified Data.Set as S +import MultipleVia +import Test.Hspec +import TransitiveAnns.Types {-# ANN t1 (Annotation Local "t1" "a") #-} @@ -21,7 +21,7 @@ t3 :: Bool t3 = False t123 :: Bool -t123 = and [t1, t2, t3] +t123 = t1 && t2 && t3 obs :: Set Annotation obs = annotated t123 diff --git a/test/MultipleVia.hs b/test/MultipleVia.hs index 8a908a0..46ea1b3 100644 --- a/test/MultipleVia.hs +++ b/test/MultipleVia.hs @@ -1,6 +1,6 @@ module MultipleVia where -import TransitiveAnns.Types +import TransitiveAnns.Types {-# ANN vt1 (Annotation Local "vt1" "a") #-} @@ -17,5 +17,5 @@ vt3 :: Bool vt3 = False vt123 :: Bool -vt123 = and [vt1, vt2, vt3] +vt123 = vt1 && vt2 && vt3 diff --git a/test/ObserveOtherModule.hs b/test/ObserveOtherModule.hs index 64a287c..4897fd6 100644 --- a/test/ObserveOtherModule.hs +++ b/test/ObserveOtherModule.hs @@ -1,8 +1,8 @@ module ObserveOtherModule where -import ObserveOtherModule2 -import TransitiveAnns.Types -import Data.Set (Set) +import Data.Set (Set) +import ObserveOtherModule2 +import TransitiveAnns.Types observeAnn :: Set Annotation observeAnn = annotated otherRefAnn diff --git a/test/ObserveOtherModule2.hs b/test/ObserveOtherModule2.hs index 2c03ba9..245f232 100644 --- a/test/ObserveOtherModule2.hs +++ b/test/ObserveOtherModule2.hs @@ -1,6 +1,6 @@ module ObserveOtherModule2 where -import TransitiveAnns.Types +import TransitiveAnns.Types -- Has direct ANN {-# ANN otherRefAnn (Annotation Local "othermodule2" "ann") #-} diff --git a/test/ObserveSameModule.hs b/test/ObserveSameModule.hs index 256ef7a..6755fb2 100644 --- a/test/ObserveSameModule.hs +++ b/test/ObserveSameModule.hs @@ -1,7 +1,7 @@ module ObserveSameModule where -import Data.Set (Set) -import TransitiveAnns.Types +import Data.Set (Set) +import TransitiveAnns.Types {-# ANN ref (Annotation Local "ref" "ref") #-} ref :: Int diff --git a/test/ObserveSameModuleSpec.hs b/test/ObserveSameModuleSpec.hs index d9429bc..6162b36 100644 --- a/test/ObserveSameModuleSpec.hs +++ b/test/ObserveSameModuleSpec.hs @@ -1,6 +1,6 @@ module ObserveSameModuleSpec where -import qualified Data.Set as S +import qualified Data.Set as S import ObserveSameModule import Test.Hspec import TransitiveAnns.Types diff --git a/test/Ring.hs b/test/Ring.hs index 9a51d59..64f8b87 100644 --- a/test/Ring.hs +++ b/test/Ring.hs @@ -1,6 +1,6 @@ module Ring where -import TransitiveAnns.Types +import TransitiveAnns.Types {-# ANN r1 (Annotation Local "ring" "1") #-} r1 :: Int diff --git a/test/RingSpec.hs b/test/RingSpec.hs index 7525497..b884ffa 100644 --- a/test/RingSpec.hs +++ b/test/RingSpec.hs @@ -1,10 +1,10 @@ module RingSpec where -import qualified Data.Set as S -import Data.Set (Set) -import TransitiveAnns.Types -import Ring -import Test.Hspec +import Data.Set (Set) +import qualified Data.Set as S +import Ring +import Test.Hspec +import TransitiveAnns.Types diff --git a/test/ToHasAnnsSpec.hs b/test/ToHasAnnsSpec.hs index 16beab9..85d491c 100644 --- a/test/ToHasAnnsSpec.hs +++ b/test/ToHasAnnsSpec.hs @@ -1,7 +1,6 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} -- COMMENT THIS LINE TO RUN THE TEST @@ -9,8 +8,8 @@ module ToHasAnnsSpec where -import TransitiveAnns.Types -import Test.Hspec +import Test.Hspec +import TransitiveAnns.Types {-# ANN test (Annotation Local "hello" "goodbye") #-} {-# ANN test (Annotation Remote "soup" "gumbo") #-} diff --git a/test/TyFamSpec.hs b/test/TyFamSpec.hs index 84c3ba1..8791b80 100644 --- a/test/TyFamSpec.hs +++ b/test/TyFamSpec.hs @@ -5,10 +5,10 @@ module TyFamSpec where -import qualified Data.Set as S -import TransitiveAnns.Types -import Test.Hspec -import GHC.TypeLits +import qualified Data.Set as S +import GHC.TypeLits +import Test.Hspec +import TransitiveAnns.Types data Component = Brig | Galley diff --git a/transitive-anns.cabal b/transitive-anns.cabal index bd539b7..94ec35f 100644 --- a/transitive-anns.cabal +++ b/transitive-anns.cabal @@ -1,90 +1,101 @@ -cabal-version: 1.12 +cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.4. +-- This file has been generated from package.yaml by hpack version 0.35.2. -- -- see: https://github.com/sol/hpack -name: transitive-anns -version: 0.1.0.0 -description: Please see the README on GitHub at -homepage: https://github.com/isovector/transitive-anns#readme -bug-reports: https://github.com/isovector/transitive-anns/issues -author: Sandy Maguire -maintainer: sandy@sandymaguire.me -copyright: Sandy Maguire -license: BSD3 -license-file: LICENSE -build-type: Simple +name: transitive-anns +version: 0.1.0.0 +description: + Please see the README on GitHub at + +homepage: https://github.com/isovector/transitive-anns#readme +bug-reports: https://github.com/isovector/transitive-anns/issues +author: Sandy Maguire +maintainer: sandy@sandymaguire.me +copyright: Sandy Maguire +license: BSD3 +license-file: LICENSE +build-type: Simple extra-source-files: - README.md - CHANGELOG.md + CHANGELOG.md + README.md source-repository head - type: git + type: git location: https://github.com/isovector/transitive-anns library exposed-modules: - TransitiveAnns.Plugin - TransitiveAnns.Plugin.Annotations - TransitiveAnns.Plugin.Core - TransitiveAnns.Plugin.Utils - TransitiveAnns.Types - other-modules: - Paths_transitive_anns - hs-source-dirs: - src + TransitiveAnns.Plugin + TransitiveAnns.Plugin.Annotations + TransitiveAnns.Plugin.Core + TransitiveAnns.Plugin.Utils + TransitiveAnns.Types + + other-modules: Paths_transitive_anns + hs-source-dirs: src default-extensions: - AllowAmbiguousTypes - DataKinds - FlexibleContexts - ScopedTypeVariables - TypeApplications - KindSignatures - ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints + AllowAmbiguousTypes + DataKinds + FlexibleContexts + KindSignatures + ScopedTypeVariables + TypeApplications + + ghc-options: + -Wall -Wcompat -Widentities -Wincomplete-record-updates + -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints + build-depends: - base >=4.7 && <5 + base >=4.7 && <5 , containers , ghc , ghc-tcplugins-extra , hspec , monoidal-containers , syb - default-language: Haskell2010 + + default-language: Haskell2010 test-suite test - type: exitcode-stdio-1.0 - main-is: Main.hs + type: exitcode-stdio-1.0 + main-is: Main.hs other-modules: - InstanceSpec - InstanceVia - LetBindingSpec - MultipleSpec - MultipleVia - ObserveOtherModule - ObserveOtherModule2 - ObserveOtherModuleSpec - ObserveSameModule - ObserveSameModuleSpec - Ring - RingSpec - ToHasAnnsSpec - TyFamSpec - Paths_transitive_anns - hs-source-dirs: - test + InstanceSpec + InstanceVia + LetBindingSpec + MultipleSpec + MultipleVia + ObserveOtherModule + ObserveOtherModule2 + ObserveOtherModuleSpec + ObserveSameModule + ObserveSameModuleSpec + Paths_transitive_anns + Ring + RingSpec + ToHasAnnsSpec + TyFamSpec + + hs-source-dirs: test default-extensions: - AllowAmbiguousTypes - DataKinds - FlexibleContexts - ScopedTypeVariables - TypeApplications - KindSignatures - ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N -fplugin=TransitiveAnns.Plugin -fno-warn-redundant-constraints -dcore-lint - build-tool-depends: - hspec-discover:hspec-discover >=2.0 + AllowAmbiguousTypes + DataKinds + FlexibleContexts + KindSignatures + ScopedTypeVariables + TypeApplications + + ghc-options: + -Wall -Wcompat -Widentities -Wincomplete-record-updates + -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints + -threaded -rtsopts -with-rtsopts=-N -fplugin=TransitiveAnns.Plugin + -fno-warn-redundant-constraints -dcore-lint + + build-tool-depends: hspec-discover:hspec-discover >=2.0 build-depends: - base >=4.7 && <5 + base >=4.7 && <5 , containers , ghc , ghc-tcplugins-extra @@ -92,4 +103,5 @@ test-suite test , monoidal-containers , syb , transitive-anns - default-language: Haskell2010 + + default-language: Haskell2010