no-recursion 0.1.2.3 → 0.2.0.0
raw patch · 18 files changed
+540/−205 lines, 18 filesdep −semigroupsdep ~basedep ~doctestdep ~ghcsetup-changed
Dependencies removed: semigroups
Dependency ranges changed: base, doctest, ghc
Files
- CHANGELOG.md +31/−11
- README.md +52/−11
- Setup.hs +0/−5
- no-recursion.cabal +47/−49
- src/NoRecursion.hs +160/−81
- src/PluginUtils.hs +93/−0
- tests/Test/Module.hs +0/−18
- tests/Test/Name.hs +0/−16
- tests/doctests.hs +1/−3
- tests/ignore/Test/AllowRecursion.hs +17/−0
- tests/ignore/Test/AnnModule.hs +19/−0
- tests/ignore/Test/AnnName.hs +17/−0
- tests/ignore/Test/IgnoreDefaultImpls.hs +30/−0
- tests/ignore/Test/UnannName.hs +17/−0
- tests/ignore/test.hs +20/−0
- tests/no-ignore/Test/IgnoreDefaultImpls.hs +27/−0
- tests/no-ignore/test.hs +9/−0
- tests/test.hs +0/−11
CHANGELOG.md view
@@ -5,45 +5,65 @@ The format is based on [Keep a Changelog 1.1](https://keepachangelog.com/en/1.1.0/), and this project adheres to the [Haskell Package Versioning Policy](https://pvp.haskell.org/). +## [0.2.0.0] – 2025-10-30++### Added++- Command-line options to avoid needing to use `Unsafe` `ann` pragmas (#19).++### Removed++- Some dependency bounds were tightened, due to changes in CI coverage.+- Support for GHC 7.10.++## [0.1.2.3] - 2025-03-30++### Added++- Wider dependency bounds to support Stackage (#21).+ ## [0.1.2.2] - 2024-09-02 ### Updated -- link to published packages in README-- add updated versioning documentation to README-- include this file in `extra-doc-files`+- Link to published packages in README.+- Add updated versioning documentation to README.+- Include this file in `extra-doc-files`. ### Removed - `-fpackage-trust` and related options because they cause more trouble than they’re worth -## [0.1.2.1] - 2024-05-26- ### Fixed -- the license report to reflect the GHC 9.10 build+- The license report to reflect the GHC 9.10 build +## 0.1.2.1++**never published**+ ## [0.1.2.0] - 2024-05-19 ### Added -- support for [GHC 9.10](https://www.haskell.org/ghc/download_ghc_9_10_1.html)+- Support for [GHC 9.10](https://www.haskell.org/ghc/download_ghc_9_10_1.html) ## [0.1.1.0] - 2024-04-16 ### Added -- source annotations (`{-# ANN … "Recursion" #-}`) to enable/disable the plugin+- Source annotations (`{-# ANN … "Recursion" #-}`) to enable/disable the plugin for limited scopes ## [0.1.0.0] - 2024-04-13 ### Added -- Initial release of this package+- Initial release of this package. -[0.1.2.2]: https://github.com/sellout/no-recursion/compare/v0.1.2.1...v0.1.2.2-[0.1.2.1]: https://github.com/sellout/no-recursion/compare/v0.1.2.0...v0.1.2.1+[0.2.0.0]: https://github.com/sellout/no-recursion/compare/v0.1.2.3...v0.2.0.0+[0.1.2.3]: https://github.com/sellout/no-recursion/compare/v0.1.2.2...v0.1.2.3+[0.1.2.2]: https://github.com/sellout/no-recursion/compare/v0.1.2.0...v0.1.2.2 [0.1.2.0]: https://github.com/sellout/no-recursion/compare/v0.1.1.0...v0.1.2.0 [0.1.1.0]: https://github.com/sellout/no-recursion/compare/v0.1.0.0...v0.1.1.0 [0.1.0.0]: https://github.com/sellout/no-recursion/releases/tag/v0..1.0.0
README.md view
@@ -14,7 +14,7 @@ Add `-fplugin NoRecursion` to your GHC options. This can be done per-module with ```haskell-{-# OPTIONS_GHC -fplugin NoRecursion #-}+{-# options_ghc -fplugin NoRecursion #-} ``` Now, any recursion in that module will result in a compilation failure.@@ -23,28 +23,47 @@ ### allowing some recursion -NoRecursion supports two source annotations: `"Recursion"` and `"NoRecursion"`.+The recommended way to re-enable recursion at the module level is to add -You can re-enable recursion for individual top-level names like+```haskell+{-# options_ghc -fplugin-opt=NoRecursion:allow-recursion:true #-}+``` +at the beginning of the file.++If you want to re-enable it for specific definitions, the best way is to use+ ```haskell+{-# options_ghc -fplugin-opt=NoRecursion:ignore-decls:recDef #-}+ recDef :: a -> b-recDef = myRecDef-{-# ANN recDef "Recursion" #-}+recDef = recDef ``` -Or you can re-enable recursion for an entire module with+You can also do it with a source annotation ```haskell-{-# ANN module "Recursion" #-}+recDef :: a -> b+recDef = recDef+{-# ann recDef "Recursion" #-} ``` +Unfortunately, the `ann` pragma isn’t allowed by [Safe Haskell](https://downloads.haskell.org/ghc/latest/docs/users_guide/exts/safe_haskell.html), so any module that uses it will be inferred as `Unsafe`. So you have to decide between an `Unsafe` (or `Trustworthy`) module and not enabling recursion for the entire module. This can be mitigated by putting recursive definitions in a module by themselves.++NoRecursion supports two [source annotations](https://downloads.haskell.org/ghc/latest/docs/users_guide/extending_ghc.html#source-annotations): `"Recursion"` and `"NoRecursion"`.++You can re-enable recursion for an entire module with++```haskell+{-# ann module "Recursion" #-}+```+ And then you can re-disable recursion for individual names with ```haskell nonRecDef :: a -> a nonRecDef = id-{-# ANN nonRecDef "NoRecursion" #-}+{-# ann nonRecDef "NoRecursion" #-} ``` If both '"Recursion"' and `"NoRecursion"` annotations exist on the same name (or module), it’s treated as `NoRecursion`.@@ -53,14 +72,36 @@ `ANN` has some caveats: -- `ANN` isn’t allowed by [Safe Haskell](https://downloads.haskell.org/ghc/latest/docs/users_guide/exts/safe_haskell.html), so any module that uses it will be inferred as `Unsafe`. - If you enable [the `OverloadedStrings` language extension](https://downloads.haskell.org/ghc/latest/docs/users_guide/exts/overloaded_strings.html), you will have to specify the type in the annotation, like ```haskell- {-# ANN module "Recursion" :: String #-}+ {-# ann module "Recursion" :: String #-} ``` -For more about how to use annotations, see [the GHC User’s Guide](https://downloads.haskell.org/ghc/latest/docs/users_guide/extending_ghc.html#source-annotations).+### plugin options++The plugin currently supports four options++- `allow-recursion`: (`true`|`false`) whether to allow recursion by default. As mentioned above, this is the best way to re-enable recursion for a single module, but you can do the reverse and specify `allow-recursion:true` globally, then use `allow-recursion:false` per-module.++- `ignore-method-cycles`: (`true`|`false`) whether to ignore cycles between method definitions.the method level. This crops up a lot with errors about things like `$csconcat`.++- `ignore-methods`: (list of method names) ignores the named methods. Very useful for silencing errors about default method definitions.++- `ignore-decls`: (list of decl names) ignores the named decls. This is good to put at the top of a module where you have intentionally written a recursive definition.++### suggestions++#### `in $csconcat, the following bindings were recursive: go1`++This particular message occurs when you define a `Semigroup` instance that didn’t have an explicit `sconcat` implementation. The default definition is recursive, and `NoRecursion` catches that. Similar messages occur with default definitions for other classes as well.++You can’t apply `ann` to methods, so here are some ways to get around this issue:++1. write an explicit non-recursive definition, or+2. add `{-# options_ghc -fplugin-opt=NoRecursion:ignore-methods:sconcat #-}` to the top of the module, which will ignore this method module-wide.++Unfortunately, because `sconcat` (and `mconcat`) require lazy lists (`[]`), it’s not possible to write a total definition for these. ## versioning
Setup.hs view
@@ -1,17 +1,12 @@ -- __NB__: `custom-setup` doesn’t have any way to specify extensions or options, -- so any we want need to be specified here.-{-# LANGUAGE CPP #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE Unsafe #-} {-# LANGUAGE NoImplicitPrelude #-}-#if MIN_VERSION_GLASGOW_HASKELL(8, 0, 0, 0) {-# OPTIONS_GHC -Weverything #-} -- Warns even when `Unsafe` is explicit, not inferred. See -- https://gitlab.haskell.org/ghc/ghc/-/issues/16689 {-# OPTIONS_GHC -Wno-unsafe #-}-#else-{-# OPTIONS_GHC -Wall #-}-#endif module Main (main) where
no-recursion.cabal view
@@ -1,7 +1,7 @@ cabal-version: 3.0 name: no-recursion-version: 0.1.2.3+version: 0.2.0.0 synopsis: A GHC plugin to remove support for recursion description: General recursion can be the cause of a lot of problems. This removes recursion from GHC, allowing you to guarantee you’re using@@ -22,7 +22,6 @@ docs/*.md tested-with: GHC == {- 7.10.3, 8.0.2, 8.2.2, 8.4.1,@@ -43,7 +42,7 @@ -- This mimics the GHC2024 extension -- (https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/control.html?highlight=doandifthenelse#extension-GHC2024),--- but supporting compilers back to GHC 7.10. If the oldest supported compiler+-- but supporting compilers back to GHC 8.0. If the oldest supported compiler -- is GHC 9.10, then this stanza can be removed and `import: GHC2024` can be -- replaced by `default-language: GHC2024`. If the oldest supported compiler is -- GHC 9.2, then this can be simplified by setting `default-language: GHC2021`@@ -88,7 +87,7 @@ StandaloneDeriving -- StandaloneKindSignatures -- uncomment if the oldest supported version is GHC 8.10.1+ TupleSections- -- TypeApplications -- uncomment if the oldest supported version is GHC 8.0.1++ TypeApplications TypeOperators UnicodeSyntax @@ -104,37 +103,30 @@ common defaults import: GHC2024 build-depends:- base ^>= {4.8.2, 4.9.1, 4.10.1, 4.11.0, 4.12.0, 4.13.0, 4.14.0, 4.15.0, 4.16.0, 4.17.0, 4.18.0, 4.19.0, 4.20.0},- if impl(ghc >= 8.0.1)- ghc-options:- -Weverything- -- This one just reports unfixable things, AFAICT.- -Wno-all-missed-specialisations- -- Type inference good.- -Wno-missing-local-signatures- -- Warns even when `Unsafe` is explicit, not inferred. See- -- https://gitlab.haskell.org/ghc/ghc/-/issues/16689- -Wno-unsafe- if impl(ghc < 8.8.1)- ghc-options:- -- This used to warn even when `Safe` was explicit.- -Wno-safe- else+ base ^>= {4.9.1, 4.10.1, 4.11.0, 4.12.0, 4.13.0, 4.14.0, 4.15.0, 4.16.0, 4.17.0, 4.18.0, 4.19.0, 4.20.0},+ ghc-options:+ -Weverything+ -- This one just reports unfixable things, AFAICT.+ -Wno-all-missed-specialisations+ -- Type inference good.+ -Wno-missing-local-signatures+ -- Warns even when `Unsafe` is explicit, not inferred. See+ -- https://gitlab.haskell.org/ghc/ghc/-/issues/16689+ -Wno-unsafe+ if impl(ghc < 8.8.1) ghc-options:- -Wall+ -- This used to warn even when `Safe` was explicit.+ -Wno-safe if impl(ghc >= 8.10.1) ghc-options:- -- If we didn’t allow inferred-safe imports, nothing would be `Safe`.- -Wno-inferred-safe-imports- -- We support GHC versions without qualified-post. -Wno-prepositive-qualified-module+ -- remove if the oldest supported version is GHC 9.2.1+ if impl(ghc >= 9.2.1) ghc-options:- -- We support GHC versions without kind signatures. -Wno-missing-kind-signatures if impl(ghc >= 9.8.1) ghc-options:- -- We support GHC versions without kind signatures.+ -- remove if the oldest supported version is GHC 9.2.1+ -Wno-missing-poly-kind-signatures -- Inference good. -Wno-missing-role-annotations@@ -149,17 +141,15 @@ -- QualifiedDo - uncomment if the oldest supported version is GHC 9.0.1+ RecursiveDo -- RequiredTypeArguments - uncomment if the oldest supported version is GHC 9.10.1+- -- TemplateHaskellQuotes - uncomment if the oldest supported version is GHC 8.0.1++ StrictData+ TemplateHaskellQuotes TransformListComp NoGeneralizedNewtypeDeriving NoImplicitPrelude NoMonomorphismRestriction NoPatternGuards -- NoStarIsType - uncomment if the oldest supported version is GHC 8.6.1+- -- NoTypeApplications - uncomment if the oldest supported version is GHC 8.0.1+- if impl(ghc >= 8.0.1)- default-extensions:- StrictData+ NoTypeApplications if flag(noisy-deprecations) cpp-options: -DSELLOUT_NOISY_DEPRECATIONS @@ -174,12 +164,11 @@ import: defaults hs-source-dirs: src build-depends:- ghc ^>= {7.10.3, 8.0.2, 8.2.2, 8.4.1, 8.6.1, 8.8.1, 8.10.1, 9.0.1, 9.2.1, 9.4.1, 9.6.1, 9.8.1, 9.10.1},- if impl(ghc < 8.0.1)- build-depends:- semigroups ^>= {0.20},+ ghc ^>= {8.0.2, 8.2.2, 8.4.1, 8.6.1, 8.8.1, 8.10.1, 9.0.1, 9.2.1, 9.4.1, 9.6.1, 9.8.1, 9.10.1}, exposed-modules: NoRecursion+ other-modules:+ PluginUtils test-suite doctests import: defaults@@ -187,11 +176,8 @@ hs-source-dirs: tests main-is: doctests.hs build-depends:- doctest ^>= {0.16.0, 0.18.1, 0.20.0, 0.21.1, 0.22.2, 0.24.0},+ doctest ^>= {0.16.0, 0.18.1, 0.20.1, 0.21.1, 0.22.2, 0.24.1}, no-recursion,- if impl(ghc < 8.0.1)- build-depends:- semigroups ^>= {0.20}, if impl(ghc >= 8.10.1) ghc-options: -- `doctest` requires the package containing the doctests as a dependency@@ -201,13 +187,9 @@ -- TODO: The sections below here are necessary because we don’t have control -- over the generated `Build_doctests.hs` file. So we have to silence -- all of its warnings one way or another.- if impl(ghc >= 8.0.1)- ghc-options:- -Wno-missing-import-lists- -Wno-safe- else- ghc-options:- -fno-warn-missing-import-lists+ ghc-options:+ -Wno-missing-import-lists+ -Wno-safe if impl(ghc >= 8.4.1) ghc-options: -Wno-missing-export-lists@@ -227,8 +209,24 @@ no-recursion, ghc-options: -fplugin NoRecursion- hs-source-dirs: tests+ hs-source-dirs: tests/ignore main-is: test.hs other-modules:- Test.Module- Test.Name+ Test.AllowRecursion+ Test.AnnModule+ Test.AnnName+ Test.IgnoreDefaultImpls+ Test.UnannName++test-suite no-ignore-annotations+ import: defaults+ type: exitcode-stdio-1.0+ build-depends:+ no-recursion,+ ghc-options:+ -fplugin NoRecursion+ -fplugin-opt NoRecursion:ignore-method-cycles:false+ hs-source-dirs: tests/no-ignore+ main-is: test.hs+ other-modules:+ Test.IgnoreDefaultImpls
src/NoRecursion.hs view
@@ -6,93 +6,155 @@ -- default. module NoRecursion (plugin) where --- NB: These unqualified modules come from semigroups in GHC <8, and base--- otherwise.-import safe Data.List.NonEmpty (NonEmpty, nonEmpty)-import safe Data.Semigroup (Semigroup ((<>)))-import safe "base" Control.Applicative (Applicative (pure))-import safe "base" Control.Category (Category ((.)))+import safe "base" Control.Applicative (liftA2, pure)+import safe "base" Control.Category ((.)) import safe "base" Control.Exception (ErrorCall (ErrorCall), throwIO) import safe "base" Control.Monad ((=<<))-import safe "base" Data.Bool (Bool (True), not, (&&), (||))-import safe "base" Data.Data (Data)+import safe "base" Data.Bool (Bool (False, True), not, (&&), (||)) import safe "base" Data.Either (Either (Left), either) import safe "base" Data.Foldable- ( Foldable (foldMap, toList),- all,+ ( all,+ any, elem,+ foldMap,+ foldr,+ foldrM, notElem,+ toList, traverse_, )-import safe "base" Data.Function (($))-import safe "base" Data.Functor (Functor (fmap), (<$>))+import safe "base" Data.Function (flip, ($))+import safe "base" Data.Functor (fmap, (<$>)) import safe "base" Data.List (filter, intercalate, isPrefixOf, null)+import safe "base" Data.List.NonEmpty (NonEmpty, nonEmpty) import safe "base" Data.Maybe (maybe)+import safe "base" Data.Semigroup (Semigroup ((<>)), (<>)) import safe "base" Data.String (String)-import safe "base" Data.Tuple (fst, uncurry)+import safe "base" Data.Tuple (curry, fst, uncurry)+import safe "this" PluginUtils+ ( Annotations,+ defaultPurePlugin,+ getAnnotations,+ processOptions,+ ) #if MIN_VERSION_ghc(9, 0, 0)-import safe "base" Data.Bifunctor (Bifunctor (first)) import qualified "ghc" GHC.Plugins as Plugins #else import qualified "ghc" GhcPlugins as Plugins #endif -defaultPurePlugin :: Plugins.Plugin-#if MIN_VERSION_ghc(8, 6, 1)-defaultPurePlugin =- Plugins.defaultPlugin {Plugins.pluginRecompile = Plugins.purePlugin}-#else-defaultPurePlugin = Plugins.defaultPlugin-#endif- -- | The entrypoint for the "NoRecursion" plugin. plugin :: Plugins.Plugin-plugin = defaultPurePlugin {Plugins.installCoreToDos = \_opts -> pure . install}+plugin =+ defaultPurePlugin+ { Plugins.installCoreToDos = \opts -> liftA2 install (parseOpts opts) . pure+ } -install :: [Plugins.CoreToDo] -> [Plugins.CoreToDo]-install = (Plugins.CoreDoPluginPass "add NoRecursion rule" noRecursionPass :)+data Opts = Opts+ { allowRecursion :: Bool,+ ignoreMethodCycles :: Bool,+ ignoredDecls :: [String],+ ignoredMethods :: [String]+ } --- | Annotations of type @a@ for a module – `fst` is the module-level--- annotations and `Data.Tuple.snd` is a map of annotations for each name in--- the module.-type Annotations a = (a, Plugins.NameEnv a)+-- | The `Opts` we have if no @-fplugin-opts=NoRecursion:@ are provided.+--+-- - recursion is not allowed+-- - recursion cycles between methods is ignored (to avoid a breaking change)+defaultOpts :: Opts+defaultOpts =+ Opts+ { allowRecursion = False,+ ignoreMethodCycles = True,+ ignoredDecls = [],+ ignoredMethods = []+ } -getAnnotations :: (Data a) => Plugins.ModGuts -> Plugins.CoreM (Annotations [a])-#if MIN_VERSION_ghc(9, 0, 1)-getAnnotations guts =- first- ( \modAnns ->- Plugins.lookupWithDefaultModuleEnv modAnns [] $- Plugins.mg_module guts+data OptError+ = MissingValue String+ | UnknownOption String+ | UnknownValue String String++prettyOptError :: OptError -> Plugins.SDoc+prettyOptError =+ Plugins.text . \case+ MissingValue opt ->+ "plugin option ‘NoRecursion:" <> opt <> "’ is missing a value"+ UnknownOption name -> "unknown plugin option ‘NoRecursion:" <> name <> "’"+ UnknownValue typ value ->+ "an option for the NoRecursion plugin was expecting a "+ <> typ+ <> " but received ‘"+ <> value+ <> "’"++parseBoolOpt :: String -> Either OptError Bool+parseBoolOpt = \case+ "true" -> pure True+ "false" -> pure False+ value -> Left $ UnknownValue "Bool" value++parseListOpt :: String -> [String]+parseListOpt =+ foldr+ ( curry $ \case+ (',', elems) -> [] : elems+ (c, []) -> [[c]]+ (c, curr : elems) -> (c : curr) : elems )- <$> Plugins.getAnnotations Plugins.deserializeWithData guts-#else-getAnnotations guts =- ( \anns ->- ( Plugins.lookupWithDefaultUFM- anns- []- ( Plugins.ModuleTarget $ Plugins.mg_module guts ::- Plugins.CoreAnnTarget- ),- anns- )- )- <$> Plugins.getAnnotations Plugins.deserializeWithData guts-#endif+ [] -noRecursionPass :: Plugins.ModGuts -> Plugins.CoreM Plugins.ModGuts-noRecursionPass guts = do+parseOpts :: [Plugins.CommandLineOption] -> Plugins.CoreM Opts+parseOpts =+ foldrM+ ( \(name, mvalue) opts ->+ case name of+ "allow-recursion" ->+ either (err opts) (\v -> pure opts {allowRecursion = v}) $+ maybe (pure True) parseBoolOpt mvalue+ "ignore-method-cycles" ->+ either (err opts) (\v -> pure opts {ignoreMethodCycles = v}) $+ maybe (pure True) parseBoolOpt mvalue+ "ignore-decls" ->+ maybe+ (err opts $ MissingValue name)+ ( \v ->+ pure opts {ignoredDecls = parseListOpt v <> ignoredDecls opts}+ )+ mvalue+ "ignore-methods" ->+ maybe+ (err opts $ MissingValue name)+ ( \v ->+ pure+ opts+ { ignoredMethods = parseListOpt v <> ignoredMethods opts+ }+ )+ mvalue+ _ -> err opts $ UnknownOption name+ )+ defaultOpts+ . processOptions+ where+ err opts = fmap (\() -> opts) . Plugins.errorMsg . prettyOptError++install :: Opts -> [Plugins.CoreToDo] -> [Plugins.CoreToDo]+install opts =+ (Plugins.CoreDoPluginPass "add NoRecursion rule" (noRecursionPass opts) :)++noRecursionPass :: Opts -> Plugins.ModGuts -> Plugins.CoreM Plugins.ModGuts+noRecursionPass opts guts = do dflags <- Plugins.getDynFlags anns <- getAnnotations guts either ( \recs -> Plugins.liftIO . throwIO . ErrorCall $- "something recursive:\n"+ "encountered recursion, which has been disabled:\n" <> intercalate "\n" (toList $ formatRecursionRecord dflags <$> recs) ) (\() -> pure guts)- . failOnRecursion dflags anns+ . failOnRecursion dflags opts anns $ Plugins.mg_binds guts data RecursionRecord b = RecursionRecord [b] (NonEmpty b)@@ -118,49 +180,66 @@ noRecursionAnnotation :: String noRecursionAnnotation = "NoRecursion" +moduleAllowsRecursion :: Bool -> [String] -> Bool+moduleAllowsRecursion allowRecursion modAnns =+ (allowRecursion || elem recursionAnnotation modAnns)+ && notElem noRecursionAnnotation modAnns++getName :: Plugins.DynFlags -> Plugins.CoreBndr -> String+getName dflags = Plugins.showSDoc dflags . Plugins.ppr++isInternalName :: Plugins.DynFlags -> Plugins.CoreBndr -> Bool+isInternalName dflags var =+ let v = getName dflags var+ in "$c" `isPrefixOf` v || "$f" `isPrefixOf` v+ failOnRecursion :: Plugins.DynFlags ->+ Opts -> Annotations [String] -> [Plugins.CoreBind] -> Either (NonEmpty (RecursionRecord Plugins.CoreBndr)) ()-failOnRecursion dflags (modAnns, nameAnns) original =- let moduleAllowsRecursion =- elem recursionAnnotation modAnns- && notElem noRecursionAnnotation modAnns- in traverse_ Left- . nonEmpty- -- __TODO__: Default method implementations seem to cause mutual- -- recursion with the instance, so here we filter them out,- -- but this probably lets some real mutual recursion slip- -- through.- . filter- ( \(RecursionRecord context recs) ->- not $- null context- && all- ( \var ->- let v = Plugins.showSDoc dflags $ Plugins.ppr var- in "$c" `isPrefixOf` v || "$f" `isPrefixOf` v- )- recs+failOnRecursion+ dflags+ opts+ (modAnns, nameAnns)+ original =+ traverse_ Left+ . nonEmpty+ -- __TODO__: Default method implementations seem to cause mutual+ -- recursion with the instance, so here we filter them out,+ -- but this probably lets some real mutual recursion slip+ -- through.+ . filter+ ( not+ . \(RecursionRecord context recs) ->+ ignoreMethodCycles opts && null context && all (isInternalName dflags) recs+ || any (flip elem (ignoredDecls opts) . getName dflags) recs+ || any (flip elem (("$c" <>) <$> ignoredMethods opts) . getName dflags) context+ )+ $ recursiveCallsForBind+ =<< filter+ ( not+ . allowBind+ (moduleAllowsRecursion (allowRecursion opts) modAnns)+ nameAnns )- $ recursiveCallsForBind- =<< filter (not . allowBind moduleAllowsRecursion nameAnns) original+ original addBindingReference :: b -> [RecursionRecord b] -> [RecursionRecord b] addBindingReference var = fmap (\(RecursionRecord context recs) -> RecursionRecord (var : context) recs) allowBind :: Bool -> Plugins.NameEnv [String] -> Plugins.CoreBind -> Bool-allowBind moduleAllowsRecursion anns = \case+allowBind modAllowsRecursion anns = \case Plugins.NonRec {} -> True- Plugins.Rec bs -> all (recursionAllowed moduleAllowsRecursion anns . fst) bs+ Plugins.Rec bs -> all (recursionAllowed modAllowsRecursion anns . fst) bs recursionAllowed :: Bool -> Plugins.NameEnv [String] -> Plugins.Var -> Bool-recursionAllowed moduleAllowsRecursion anns var =+recursionAllowed modAllowsRecursion anns var = let strAnns = Plugins.lookupWithDefaultUFM_Directly anns [] $ Plugins.getUnique var- in (moduleAllowsRecursion || elem recursionAnnotation strAnns)+ in (modAllowsRecursion || elem recursionAnnotation strAnns) && notElem noRecursionAnnotation strAnns recursiveCallsForBind :: Plugins.Bind b -> [RecursionRecord b]
+ src/PluginUtils.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE Trustworthy #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++-- |+--+-- __TODO__: Make a separate package with general plugin utilities.+module PluginUtils+ ( defaultPurePlugin,+ Annotations,+ getAnnotations,+ processOptions,+ )+where++import safe "base" Control.Applicative (pure)+import safe "base" Control.Category ((.))+import safe "base" Data.Bifunctor (second)+import safe "base" Data.Data (Data)+import safe "base" Data.Function (flip, ($))+import safe "base" Data.Functor (fmap, (<$>))+import safe "base" Data.List (drop, elemIndex, splitAt)+import safe "base" Data.Maybe (Maybe (Nothing), maybe)+import safe "base" Data.String (String)+#if MIN_VERSION_ghc(9, 0, 0)+import safe "base" Data.Bifunctor (first)+import qualified "ghc" GHC.Plugins as Plugins+#else+import qualified "ghc" GhcPlugins as Plugins+#endif+-- hlint wants these to be combined with the unconditional imports above.+{-# HLINT ignore "Use fewer imports" #-}+#if MIN_VERSION_ghc(8, 6, 0)+import safe "base" Data.List (reverse)+#else+import safe "base" Control.Category (id)+#endif++defaultPurePlugin :: Plugins.Plugin+#if MIN_VERSION_ghc(8, 6, 1)+defaultPurePlugin =+ Plugins.defaultPlugin {Plugins.pluginRecompile = Plugins.purePlugin}+#else+defaultPurePlugin = Plugins.defaultPlugin+#endif++-- | Annotations of type @a@ for a module – `fst` is the module-level+-- annotations and `Data.Tuple.snd` is a map of annotations for each name in+-- the module.+type Annotations a = (a, Plugins.NameEnv a)++getAnnotations :: (Data a) => Plugins.ModGuts -> Plugins.CoreM (Annotations [a])+#if MIN_VERSION_ghc(9, 0, 1)+getAnnotations guts =+ first+ ( \modAnns ->+ Plugins.lookupWithDefaultModuleEnv modAnns [] $+ Plugins.mg_module guts+ )+ <$> Plugins.getAnnotations Plugins.deserializeWithData guts+#else+getAnnotations guts =+ ( \anns ->+ ( Plugins.lookupWithDefaultUFM+ anns+ []+ ( Plugins.ModuleTarget $ Plugins.mg_module guts ::+ Plugins.CoreAnnTarget+ ),+ anns+ )+ )+ <$> Plugins.getAnnotations Plugins.deserializeWithData guts+#endif++-- | Starting with GHC 8.6, plugin option order is reversed from what’s provided+-- on the command line. This normalizes it to always match the command-line+-- order.+correctOptionOrder :: [Plugins.CommandLineOption] -> [Plugins.CommandLineOption]+#if MIN_VERSION_ghc(8, 6, 1)+correctOptionOrder = reverse+#else+correctOptionOrder = id+#endif++processOption :: Plugins.CommandLineOption -> (String, Maybe String)+processOption opt =+ maybe (opt, Nothing) (second (pure . drop 1) . flip splitAt opt) $+ elemIndex ':' opt++-- | This splits each option on `:`, returning a separate “value” if it exists.+processOptions :: [Plugins.CommandLineOption] -> [(String, Maybe String)]+processOptions = fmap processOption . correctOptionOrder
− tests/Test/Module.hs
@@ -1,18 +0,0 @@-{-# LANGUAGE Unsafe #-}--module Test.Module- ( recDef,- nonRecDef,- )-where--import safe "base" Control.Category (Category (id))--{-# ANN module "Recursion" #-}--recDef :: a -> b-recDef = recDef--nonRecDef :: a -> a-nonRecDef = id-{-# ANN nonRecDef "NoRecursion" #-}
− tests/Test/Name.hs
@@ -1,16 +0,0 @@-{-# LANGUAGE Unsafe #-}--module Test.Name- ( recDef,- nonRecDef,- )-where--import safe "base" Control.Category (Category (id))--recDef :: a -> b-recDef = recDef-{-# ANN recDef "Recursion" #-}--nonRecDef :: a -> a-nonRecDef = id
tests/doctests.hs view
@@ -2,10 +2,8 @@ module Main (main) where --- NB: This unqualified module comes from semigroups in GHC <8, and base--- otherwise.-import safe Data.Semigroup (Semigroup ((<>))) import safe "base" Data.Function (($))+import safe "base" Data.Semigroup ((<>)) import safe "base" System.IO (IO) import "doctest" Test.DocTest (doctest) import "this" Build_doctests (flags, module_sources, pkgs)
+ tests/ignore/Test/AllowRecursion.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE Safe #-}+-- Removing this line should cause this module to not compile.+{-# OPTIONS_GHC -fplugin-opt=NoRecursion:allow-recursion:true #-}++module Test.AllowRecursion+ ( recDef,+ nonRecDef,+ )+where++import "base" Control.Category (id)++recDef :: a -> b+recDef = recDef++nonRecDef :: a -> a+nonRecDef = id
+ tests/ignore/Test/AnnModule.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE Unsafe #-}++module Test.AnnModule+ ( recDef,+ nonRecDef,+ )+where++import safe "base" Control.Category (id)++-- Removing this line should cause this module to not compile.+{-# ANN module "Recursion" #-}++recDef :: a -> b+recDef = recDef++nonRecDef :: a -> a+nonRecDef = id+{-# ANN nonRecDef "NoRecursion" #-}
+ tests/ignore/Test/AnnName.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE Unsafe #-}++module Test.AnnName+ ( recDef,+ nonRecDef,+ )+where++import safe "base" Control.Category (id)++recDef :: a -> b+recDef = recDef+-- Removing this line should cause this module to not compile.+{-# ANN recDef "Recursion" #-}++nonRecDef :: a -> a+nonRecDef = id
+ tests/ignore/Test/IgnoreDefaultImpls.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE Safe #-}+-- Adding this line should cause this module to not compile.+-- {-# OPTIONS_GHC -fplugin-opt=NoRecursion:ignore-method-cycles:false #-}+-- Removing this line should cause this module to not compile.+{-# OPTIONS_GHC -fplugin-opt=NoRecursion:ignore-methods:sconcat,stimes #-}++-- | Without @-fplugin-opt=NoRecursion:no-ignore-default-impls@ specified during+-- compilation, default definitions won’t trigger an error.+module Test.IgnoreDefaultImpls+ ( Example (Empty, NotEmpty),+ )+where++import "base" Data.Function (($))+import "base" Data.Monoid (Monoid, mappend, mempty)+import "base" Data.Semigroup (Semigroup, (<>))+import "base" Data.Tuple (curry)++data Example+ = Empty+ | NotEmpty++instance Semigroup Example where+ (<>) = curry $ \case+ (Empty, Empty) -> Empty+ (_, _) -> NotEmpty++instance Monoid Example where+ mappend = (<>)+ mempty = Empty
+ tests/ignore/Test/UnannName.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE Safe #-}+-- Removing this line should cause this module to not compile.+{-# OPTIONS_GHC -fplugin-opt=NoRecursion:ignore-decls:recDef #-}++module Test.UnannName+ ( recDef,+ nonRecDef,+ )+where++import "base" Control.Category (id)++recDef :: a -> b+recDef = recDef++nonRecDef :: a -> a+nonRecDef = id
+ tests/ignore/test.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE Trustworthy #-}++import safe "base" Control.Applicative (pure)+import safe "base" Control.Category ((.))+import safe "base" Data.Function (const, ($))+import safe "base" System.IO (IO)+import safe qualified "this" Test.AllowRecursion as AllowRecursion+import qualified "this" Test.AnnModule as AnnModule+import qualified "this" Test.AnnName as AnnName+import safe qualified "this" Test.IgnoreDefaultImpls as IgnoreDefaultImpls+import safe qualified "this" Test.UnannName as UnannName++main :: IO ()+main =+ pure+ . AllowRecursion.nonRecDef+ . AnnModule.nonRecDef+ . AnnName.nonRecDef+ . UnannName.nonRecDef+ $ const () IgnoreDefaultImpls.Empty
+ tests/no-ignore/Test/IgnoreDefaultImpls.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE Safe #-}+-- Removing either of these lines should cause this module to not compile.+{-# OPTIONS_GHC -fplugin-opt=NoRecursion:ignore-method-cycles:true #-}+{-# OPTIONS_GHC -fplugin-opt=NoRecursion:ignore-methods:sconcat,stimes #-}++module Test.IgnoreDefaultImpls+ ( Example (Empty, NotEmpty),+ )+where++import "base" Data.Function (($))+import "base" Data.Monoid (Monoid, mappend, mempty)+import "base" Data.Semigroup (Semigroup, (<>))+import "base" Data.Tuple (curry)++data Example+ = Empty+ | NotEmpty++instance Semigroup Example where+ (<>) = curry $ \case+ (Empty, Empty) -> Empty+ (_, _) -> NotEmpty++instance Monoid Example where+ mappend = (<>)+ mempty = Empty
+ tests/no-ignore/test.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE Safe #-}++import "base" Control.Applicative (pure)+import "base" Data.Function (const, ($))+import "base" System.IO (IO)+import qualified "this" Test.IgnoreDefaultImpls as IgnoreDefaultImpls++main :: IO ()+main = pure $ const () IgnoreDefaultImpls.Empty
− tests/test.hs
@@ -1,11 +0,0 @@-{-# LANGUAGE Trustworthy #-}--import safe "base" Control.Applicative (Applicative (pure))-import safe "base" Control.Category (Category ((.)))-import safe "base" Data.Function (($))-import safe "base" System.IO (IO)-import qualified "this" Test.Module as Module-import qualified "this" Test.Name as Name--main :: IO ()-main = pure . Module.nonRecDef $ Name.nonRecDef ()