diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,68 @@ +# NoRecursion plugin + +A GHC plugin to remove support for recursion + +General recursion can be the cause of a lot of problems. This removes recursion from GHC, allowing you to guarantee you’re using other mechanisms, like recursion schemes. + +## usage + +Add `no-recursion` to your build dependencies. + +Add `-fplugin NoRecursion` to your GHC options. This can be done per-module with + +```haskell +{-# OPTIONS_GHC -fplugin NoRecursion #-} +``` + +Now, any recursion in that module will result in a compilation failure. + +**NB**: This won’t prevent you from using recursive functions imported from other modules, but inlined definitions from other modules _will_ be checked. + +### allowing some recursion + +NoRecursion supports two source annotations: `"Recursion"` and `"NoRecursion"`. + +You can re-enable recursion for individual top-level names like + +```haskell +recDef :: a -> b +recDef = myRecDef +{-# ANN recDef "Recursion" #-} +``` + +Or 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" #-} +``` + +If both '"Recursion"' and `"NoRecursion"` annotations exist on the same name (or module), it’s treated as `NoRecursion`. + +**NB**: If multiple names are mutually recursive, then they must all have recursion enabled to avoid being flagged by the plugin. + +`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 #-} + ``` + +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). + +## comparisons + +Other projects similar to this one, and how they differ. + +### [WartRemover](https://www.wartremover.org/) + +WartRemover is a Scala linting tool. [A `Recursion` wart](https://www.wartremover.org/doc/warts.html#recursion) was added in 2017, and I’ve been meaning to write this plugin ever since. It only took seven years to find a few hours to make it happen … 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.0.0 +version: 0.1.1.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 @@ -16,9 +16,12 @@ license: AGPL-3.0-or-later license-files: LICENSE +extra-doc-files: + README.md tested-with: GHC == { -- GHCup Nixpkgs + 7.10.3, 8.0.2, 8.2.2, 8.4.1, @@ -94,13 +97,13 @@ common defaults import: GHC2021 build-depends: - 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}, + 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}, ghc-options: - -Weverything -fpackage-trust -trust base if impl(ghc >= 8.0.1) ghc-options: + -Weverything -- This one just reports unfixable things, AFAICT. -Wno-all-missed-specialisations -- Type inference good. @@ -112,6 +115,9 @@ ghc-options: -- This used to warn even when `Safe` was explicit. -Wno-safe + else + ghc-options: + -Wall if impl(ghc >= 8.10.1) ghc-options: -- If we didn’t allow inferred-safe imports, nothing would be `Safe`. @@ -160,14 +166,20 @@ setup-depends: -- TODO: Remove `Cabal` dep once haskell/cabal#3751 is fixed. Cabal ^>= {3.0.0, 3.2.0, 3.4.0, 3.6.0, 3.8.0, 3.10.0}, - base ^>= {4.8.2, 4.9.0, 4.10.0, 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}, - cabal-doctest ^>= 1.0.0, + 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}, + cabal-doctest ^>= {1.0.0}, library import: defaults hs-source-dirs: src build-depends: - 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}, + 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}, + if impl(ghc < 8.0.1) + build-depends: + semigroups ^>= {0.20}, + ghc-options: + -trust containers + -trust semigroups exposed-modules: NoRecursion @@ -182,9 +194,17 @@ -- 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. - ghc-options: - -Wno-missing-import-lists - -Wno-safe + if impl(ghc >= 8.0.1) + ghc-options: + -Wno-missing-import-lists + -Wno-safe + else + build-depends: + semigroups ^>= {0.20}, + ghc-options: + -fno-warn-missing-import-lists + -trust containers + -trust semigroups if impl(ghc >= 8.4.1) ghc-options: -Wno-missing-export-lists @@ -197,3 +217,16 @@ -- “Build_doctests.hs”, we set it here, and that means it has to match -- doctests.hs, which is `Unsafe`. Unsafe + +test-suite annotations + import: defaults + type: exitcode-stdio-1.0 + build-depends: + no-recursion, + ghc-options: + -fplugin NoRecursion + hs-source-dirs: tests + main-is: test.hs + other-modules: + Test.Module + Test.Name diff --git a/src/NoRecursion.hs b/src/NoRecursion.hs --- a/src/NoRecursion.hs +++ b/src/NoRecursion.hs @@ -6,22 +6,32 @@ -- 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.Exception (ErrorCall (ErrorCall), throwIO) import safe "base" Control.Monad ((=<<)) -import safe "base" Data.Bool (not, (&&), (||)) +import safe "base" Data.Bool (Bool (True), not, (&&), (||)) +import safe "base" Data.Data (Data) import safe "base" Data.Either (Either (Left), either) -import safe "base" Data.Foldable (Foldable (foldMap, toList), all) +import safe "base" Data.Foldable + ( Foldable (foldMap, toList), + all, + elem, + notElem, + traverse_, + ) import safe "base" Data.Function (($)) import safe "base" Data.Functor (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) +import safe "base" Data.Tuple (fst, uncurry) #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 @@ -35,23 +45,54 @@ defaultPurePlugin = Plugins.defaultPlugin #endif +-- | The entrypoint for the `NoRecursion` plugin. plugin :: Plugins.Plugin plugin = defaultPurePlugin {Plugins.installCoreToDos = \_opts -> pure . install} install :: [Plugins.CoreToDo] -> [Plugins.CoreToDo] install = (Plugins.CoreDoPluginPass "add NoRecursion rule" noRecursionPass :) +-- | 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 + noRecursionPass :: Plugins.ModGuts -> Plugins.CoreM Plugins.ModGuts noRecursionPass guts = do dflags <- Plugins.getDynFlags + anns <- getAnnotations guts either ( \recs -> Plugins.liftIO . throwIO . ErrorCall $ "something recursive:\n" <> intercalate "\n" (toList $ formatRecursionRecord dflags <$> recs) ) - (\binds -> pure guts {Plugins.mg_binds = binds}) - . failOnRecursion dflags + (\() -> pure guts) + . failOnRecursion dflags anns $ Plugins.mg_binds guts data RecursionRecord b = RecursionRecord [b] (NonEmpty b) @@ -71,46 +112,68 @@ <> ", the following bindings were recursive: " <> intercalate ", " (Plugins.showSDoc dflags . Plugins.ppr <$> toList recs) +recursionAnnotation :: String +recursionAnnotation = "Recursion" + +noRecursionAnnotation :: String +noRecursionAnnotation = "NoRecursion" + failOnRecursion :: - (Plugins.Outputable b) => Plugins.DynFlags -> - [Plugins.Bind b] -> - Either (NonEmpty (RecursionRecord b)) [Plugins.Bind b] -failOnRecursion dflags original = - maybe (pure original) 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 - ) - $ recursiveCallsForBind =<< original + 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 + ) + $ recursiveCallsForBind + =<< filter (not . allowBind moduleAllowsRecursion nameAnns) 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 + Plugins.NonRec {} -> True + Plugins.Rec bs -> all (recursionAllowed moduleAllowsRecursion anns . fst) bs + +recursionAllowed :: Bool -> Plugins.NameEnv [String] -> Plugins.Var -> Bool +recursionAllowed moduleAllowsRecursion anns var = + let strAnns = + Plugins.lookupWithDefaultUFM_Directly anns [] $ Plugins.getUnique var + in (moduleAllowsRecursion || elem recursionAnnotation strAnns) + && notElem noRecursionAnnotation strAnns + recursiveCallsForBind :: Plugins.Bind b -> [RecursionRecord b] -recursiveCallsForBind = \case - Plugins.NonRec v rhs -> addBindingReference v $ collectRecursiveCalls rhs - Plugins.Rec binds -> - let nestedRecursion = - foldMap - (\(v, rhs) -> addBindingReference v $ collectRecursiveCalls rhs) - binds - in maybe - nestedRecursion - (\bnds -> RecursionRecord [] (fst <$> bnds) : nestedRecursion) - $ nonEmpty binds +recursiveCallsForBind = + let collectCalls v = addBindingReference v . collectRecursiveCalls + in \case + Plugins.NonRec v rhs -> collectCalls v rhs + Plugins.Rec binds -> + let nestedRecursion = foldMap (uncurry collectCalls) binds + in maybe + nestedRecursion + (\bnds -> RecursionRecord [] (fst <$> bnds) : nestedRecursion) + $ nonEmpty binds -- | This collects all identifiable recursion points in an expression. collectRecursiveCalls :: Plugins.Expr b -> [RecursionRecord b] diff --git a/tests/Test/Module.hs b/tests/Test/Module.hs new file mode 100644 --- /dev/null +++ b/tests/Test/Module.hs @@ -0,0 +1,18 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/tests/Test/Name.hs @@ -0,0 +1,16 @@ +{-# 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,8 +2,10 @@ 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 (Semigroup ((<>))) import safe "base" System.IO (IO) import "doctest" Test.DocTest (doctest) import "this" Build_doctests (flags, module_sources, pkgs) diff --git a/tests/test.hs b/tests/test.hs new file mode 100644 --- /dev/null +++ b/tests/test.hs @@ -0,0 +1,11 @@ +{-# 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 ()