diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -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 diff --git a/no-recursion.cabal b/no-recursion.cabal --- a/no-recursion.cabal +++ b/no-recursion.cabal @@ -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 diff --git a/src/NoRecursion.hs b/src/NoRecursion.hs --- a/src/NoRecursion.hs +++ b/src/NoRecursion.hs @@ -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] diff --git a/src/PluginUtils.hs b/src/PluginUtils.hs new file mode 100644 --- /dev/null +++ b/src/PluginUtils.hs @@ -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 diff --git a/tests/Test/Module.hs b/tests/Test/Module.hs deleted file mode 100644 --- a/tests/Test/Module.hs +++ /dev/null @@ -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" #-} diff --git a/tests/Test/Name.hs b/tests/Test/Name.hs deleted file mode 100644 --- a/tests/Test/Name.hs +++ /dev/null @@ -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 diff --git a/tests/doctests.hs b/tests/doctests.hs --- a/tests/doctests.hs +++ b/tests/doctests.hs @@ -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) diff --git a/tests/ignore/Test/AllowRecursion.hs b/tests/ignore/Test/AllowRecursion.hs new file mode 100644 --- /dev/null +++ b/tests/ignore/Test/AllowRecursion.hs @@ -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 diff --git a/tests/ignore/Test/AnnModule.hs b/tests/ignore/Test/AnnModule.hs new file mode 100644 --- /dev/null +++ b/tests/ignore/Test/AnnModule.hs @@ -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" #-} diff --git a/tests/ignore/Test/AnnName.hs b/tests/ignore/Test/AnnName.hs new file mode 100644 --- /dev/null +++ b/tests/ignore/Test/AnnName.hs @@ -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 diff --git a/tests/ignore/Test/IgnoreDefaultImpls.hs b/tests/ignore/Test/IgnoreDefaultImpls.hs new file mode 100644 --- /dev/null +++ b/tests/ignore/Test/IgnoreDefaultImpls.hs @@ -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 diff --git a/tests/ignore/Test/UnannName.hs b/tests/ignore/Test/UnannName.hs new file mode 100644 --- /dev/null +++ b/tests/ignore/Test/UnannName.hs @@ -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 diff --git a/tests/ignore/test.hs b/tests/ignore/test.hs new file mode 100644 --- /dev/null +++ b/tests/ignore/test.hs @@ -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 diff --git a/tests/no-ignore/Test/IgnoreDefaultImpls.hs b/tests/no-ignore/Test/IgnoreDefaultImpls.hs new file mode 100644 --- /dev/null +++ b/tests/no-ignore/Test/IgnoreDefaultImpls.hs @@ -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 diff --git a/tests/no-ignore/test.hs b/tests/no-ignore/test.hs new file mode 100644 --- /dev/null +++ b/tests/no-ignore/test.hs @@ -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 diff --git a/tests/test.hs b/tests/test.hs deleted file mode 100644 --- a/tests/test.hs +++ /dev/null @@ -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 ()