packages feed

no-recursion 0.1.0.0 → 0.1.1.0

raw patch · 7 files changed

+260/−49 lines, 7 filesdep +semigroupsdep ~basedep ~ghc

Dependencies added: semigroups

Dependency ranges changed: base, ghc

Files

+ README.md view
@@ -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 …
no-recursion.cabal view
@@ -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
src/NoRecursion.hs view
@@ -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]
+ tests/Test/Module.hs view
@@ -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" #-}
+ tests/Test/Name.hs view
@@ -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
tests/doctests.hs view
@@ -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)
+ tests/test.hs view
@@ -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 ()