henforcer (empty) → 1.0.0.0
raw patch · 41 files changed
+3947/−0 lines, 41 filesdep +basedep +containersdep +dlistsetup-changed
Dependencies added: base, containers, dlist, filepattern, ghc, hedgehog, henforcer, optparse-applicative, pollock, tasty, tasty-hedgehog, text, tomland
Files
- ChangeLog.md +7/−0
- LICENSE +20/−0
- README.md +198/−0
- Setup.hs +3/−0
- henforcer.cabal +177/−0
- plugin/Henforcer.hs +99/−0
- src/CompatGHC.hs +296/−0
- src/Henforcer/Checks.hs +15/−0
- src/Henforcer/Checks/DocumentationCheck.hs +538/−0
- src/Henforcer/Checks/ImportCheck.hs +15/−0
- src/Henforcer/Checks/ImportCheck/Check.hs +367/−0
- src/Henforcer/Checks/ImportCheck/CheckFailure.hs +261/−0
- src/Henforcer/CodeStructure.hs +15/−0
- src/Henforcer/CodeStructure/Import.hs +16/−0
- src/Henforcer/CodeStructure/Import/AllowedAliasUniqueness.hs +73/−0
- src/Henforcer/CodeStructure/Import/Import.hs +65/−0
- src/Henforcer/CodeStructure/Import/Scheme.hs +17/−0
- src/Henforcer/CodeStructure/Import/Scheme/Alias.hs +49/−0
- src/Henforcer/CodeStructure/Import/Scheme/PackageQualifier.hs +55/−0
- src/Henforcer/CodeStructure/Import/Scheme/Safe.hs +56/−0
- src/Henforcer/CodeStructure/Import/Scheme/Scheme.hs +205/−0
- src/Henforcer/CodeStructure/ModuleTree.hs +131/−0
- src/Henforcer/Config.hs +19/−0
- src/Henforcer/Config/Config.hs +45/−0
- src/Henforcer/Config/ForAnyModule.hs +109/−0
- src/Henforcer/Config/ForPatternModule.hs +90/−0
- src/Henforcer/Config/ForSpecifiedModule.hs +114/−0
- src/Henforcer/Config/IgnoreRules.hs +127/−0
- src/Henforcer/Config/TreeDependencies.hs +36/−0
- src/Henforcer/Options.hs +37/−0
- src/Henforcer/Rules.hs +18/−0
- src/Henforcer/Rules/ConditionallyEnforced.hs +35/−0
- src/Henforcer/Rules/Maximum.hs +61/−0
- src/Henforcer/Rules/Minimum.hs +69/−0
- src/Henforcer/Rules/MustExistNonEmpty.hs +47/−0
- src/Henforcer/Rules/UserNote.hs +64/−0
- src/TomlHelper.hs +35/−0
- test/Main.hs +15/−0
- test/Test/Config.hs +19/−0
- test/Test/Config/Documentation.hs +113/−0
- test/Test/Config/Import.hs +216/−0
+ ChangeLog.md view
@@ -0,0 +1,7 @@+# Changelog for Henforcer++## Unreleased changes++## 1.0.0.0 -- 2026-01-27++* First released version after many years of internal use.
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2020-2026 Flipstone Technology Partners++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ README.md view
@@ -0,0 +1,198 @@+# henforcer++`henforcer` is a `Haskell` enforcer of project specific code standards.++## Installation/Execution++`henforcer` is a GHC plugin, thus it is executed during compilation. To enable the plugin during+compilation with `cabal` or `stack`, add `henforcer` as a dependency in your cabal file or+package.yaml as applicable and add `-fplugin Henforcer` to `ghc-flags`. Specifying plugin options is+done with `ghc-flags` as well. Currently only supported is the path to the configuration, which if+it is at `foo/bar/henforcer.toml` this would be as+`"-fplugin-opt=Henforcer:-cfoo/bar/henforcer.toml"`.++_Note: `henforcer` requires a handful of packages that are not on stackage as of lts-24.29. The following is likely to needed in the `extra-deps` section of your `stack.yaml`++```+# henforcer needs pollock+- pollock-0.1.0.4+```++## Configuration++`henforcer` uses `TOML` files for configuration. You can use a empty toml file as a beginning configuration. Using such and running `henforcer` will not report errors.++Configuration concepts and options are described below. Also the `examples/henforcer.toml` file+shows a variety of usage possibilities.++### Concepts++#### Module Trees++`henforcer` uses "module trees" as part of its configuration. A "module tree" refers to a root+module (e.g. `Data.Text`) and all the modules are prefixed by it (e.g. `Data.Text.Encoding` and+`Data.Text.Lazy`). For modules in your project this almost always means a `src/Foo/MyModule.hs` file+and any `.hs` files contained inside the `src/Foo/MyModule` directory.++## Configuration reference++### forAnyModule++The `forAnyModule` key is a TOML table containing all of the checks that apply when compiling any+given module. You can think of these as "global" but they do *not* apply to multiple modules at+once.++| fieldName | type | required | description |+|--------------------------------------------|-------------------------------|----------|-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------|+| `allowedAliasUniqueness` | AllowedAliasUniqueness | no | Specifies either that all aliases in the module being compiled are unique except for some, or that a given set of aliases is unique but others may be duplicated. |+| `allowedOpenUnaliasedImports` | non-negative int | no | Specifies how many imports are allowed to be done without using the `qualified` keyword, or using an `alias` |+| `allowedQualifications` | array of AllowedQualification | no | Represents how certain modules should be imported. This can be thought of as a map of module name to a list of ways that module may be imported. |+| `encapsulatedTrees` | array of string | yes | Lets you declare that the root of a module tree is effectively a public interface that any modules outside the tree should be using. `henforcer` will report an error if any module outside the tree attempts to import a module from inside the encapsulated tree. |+| `maximumExportsPlusHeaderUndocumented` | non-negative integer | no | Maximum number of exported items, along with the module header, from a module that may be missing Haddock documentation. |+| `minimumExportsPlusHeaderDocumented` | non-negative integer | no | Minimum number of exported items, along with the module header, from a module that must have Haddock documentation. |+| `maximumExportsWithoutSince` | non-negative integer | no | Maximum number of exported items from a module that can be lacking the `@since` annotation in their Haddock. |+| `minimumExportsWithSince` | non-negative integer | no | Minimum number of exported items from a module that must have in their Haddock the `@since` annotation. |+| `moduleHeaderCopyrightMustExistNonEmpty` | boolean | no | If the `Haddock` module header field of `Copyright` must be populated. |+| `moduleHeaderDescriptionMustExistNonEmpty` | boolean | no | If the `Haddock` module header field of `Description` must be populated. |+| `moduleHeaderLicenseMustExistNonEmpty` | boolean | no | If the `Haddock` module header field of `License` must be populated. |+| `moduleHeaderMaintainerMustExistNonEmpty` | boolean | no | If the `Haddock` module header field of `Maintainer` must be populated. |+| `treeDependencies` | array of TreeDependency | no | Declares that one module tree depends on other trees. Declaring such a dependency tells `henforcer` that you don't want the dependency targets to import anything from the dependent tree, which would cause a backwards dependency rendering the two module trees logically inseparable. |++### forSpecifiedModules++Henforcer allows for certain rules to be overridden on a module by module basis. When provided, the+most specific rule will be applied.++| fieldName | type | required | description |+|--------------------------------------------|-------------------------------|----------|-------------------------------------------------------------------------------------------------------------------------------------------------------------------|+| `module` | string | yes | `module` is a string of the module name the rules in this table will apply to. |+| `allowedAliasUniqueness` | AllowedAliasUniqueness | no | Specifies either that all aliases in the module being compiled are unique except for some, or that a given set of aliases is unique but others may be duplicated. |+| `allowedOpenUnaliasedImports` | non-negative int | no | Specifies how many imports are allowed to be done without using the `qualified` keyword, or using an `alias` |+| `allowedQualifications` | array of AllowedQualification | no | Represents how certain modules should be imported. This can be thought of as a map of module name to a list of ways that module may be imported. |+| `maximumExportsPlusHeaderUndocumented` | non-negative integer | no | Maximum number of exported items, along with the module header, from a module that may be missing Haddock documentation. |+| `minimumExportsPlusHeaderDocumented` | non-negative integer | no | Minimum number of exported items, along with the module header, from a module that must have Haddock documentation. |+| `maximumExportsWithoutSince` | non-negative integer | no | Maximum number of exported items from a module that can be lacking the `@since` annotation in their Haddock. |+| `minimumExportsWithSince` | non-negative integer | no | Minimum number of exported items from a module that must have in their Haddock the `@since` annotation. |+| `moduleHeaderCopyrightMustExistNonEmpty` | boolean | no | If the `Haddock` module header field of `Copyright` must be populated. |+| `moduleHeaderDescriptionMustExistNonEmpty` | boolean | no | If the `Haddock` module header field of `Description` must be populated. |+| `moduleHeaderLicenseMustExistNonEmpty` | boolean | no | If the `Haddock` module header field of `License` must be populated. |+| `moduleHeaderMaintainerMustExistNonEmpty` | boolean | no | If the `Haddock` module header field of `Maintainer` must be populated. |+| `rulesToIgnore` | RulesToIgnore | no | Specifies what, if any, rules should be ignored for the given module. |++### forPatternModules++Henforcer supports a limited form of using patterns to match rules against multiple modules, but not any module in a more concise way.++`forPatternModules` is an array of TOML tables. Effectively this is a map keyed by the `pattern` field.++Important items to note:+ - When determining which version of a rule to pick the definition in `forSpecifiedModules` is most+ preferred, followed by `forPatternModules` and finally `forAnyModule`.+ - If there are overlapping `pattern` keys in `forPatternModules` the first specified in the TOML will be chosen.+ - Patterns use `*` and `**`. `*` can be used to match up to the module separator `.`, where `**`+ matches across the `.` separator.++| fieldName | type | required | description |+|--------------------------------------------|-------------------------------|----------|-------------------------------------------------------------------------------------------------------------------------------------------------------------------|+| `pattern` | string with wildcard | yes | `module` is a string, with wildcard support, of the module name the rules described here will apply to. |+| `allowedAliasUniqueness` | AllowedAliasUniqueness | no | Specifies either that all aliases in the module being compiled are unique except for some, or that a given set of aliases is unique but others may be duplicated. |+| `allowedOpenUnaliasedImports` | non-negative int | no | Specifies how many imports are allowed to be done without using the `qualified` keyword, or using an `alias` |+| `allowedQualifications` | array of AllowedQualification | no | Represents how certain modules should be imported. This can be thought of as a map of module name to a list of ways that module may be imported. |+| `maximumExportsPlusHeaderUndocumented` | non-negative integer | no | Maximum number of exported items, along with the module header, from a module that may be missing Haddock documentation. |+| `minimumExportsPlusHeaderDocumented` | non-negative integer | no | Minimum number of exported items, along with the module header, from a module that must have Haddock documentation. |+| `maximumExportsWithoutSince` | non-negative integer | no | Maximum number of exported items from a module that can be lacking the `@since` annotation in their Haddock. |+| `minimumExportsWithSince` | non-negative integer | no | Minimum number of exported items from a module that must have in their Haddock the `@since` annotation. |+| `moduleHeaderCopyrightMustExistNonEmpty` | boolean | no | If the `Haddock` module header field of `Copyright` must be populated. |+| `moduleHeaderDescriptionMustExistNonEmpty` | boolean | no | If the `Haddock` module header field of `Description` must be populated. |+| `moduleHeaderLicenseMustExistNonEmpty` | boolean | no | If the `Haddock` module header field of `License` must be populated. |+| `moduleHeaderMaintainerMustExistNonEmpty` | boolean | no | If the `Haddock` module header field of `Maintainer` must be populated. |+| `rulesToIgnore` | RulesToIgnore | no | Specifies what, if any, rules should be ignored for the given module. |++### Shared types++Below are the reused definitions between some combination of the `forAnyModule`, `forSpecifiedModules` and `forPatternModules` rules.++#### AllowedAliasUniqueness++This is allowed to take two forms that are both TOML tables.++##### First Form++This form states that all aliases in a module must be unique with an allow list for those aliases+that may be repeated.++| fieldName | type | required | description |+|--------------------------|-----------------|----------|--------------------------------------------------------------------------|+| `allAliasesUniqueExcept` | array of string | yes | Aliases that are allowed to be repeated. |+| `note` | string | no | User defined message to be displayed with errors for additional context. |++##### Second Form++This form states that aliases in a module may repeat with a block list for those aliases+that must be unique.++| fieldName | type | required | description |+|-----------------|-----------------|----------|--------------------------------------------------------------------------|+| `uniqueAliases` | array of string | yes | Aliases that must be unique. |+| `note` | string | no | User defined message to be displayed with errors for additional context. |++#### AllowedQualification++| fieldName | type | required | description |+|----------------|-----------------------|----------|-----------------------------------------------------------------------------|+| `module` | string | yes | `module` is a string of the module name. |+| `importScheme` | array of ImportScheme | yes | The list of specifications for each way that the given module may imported. |++#### ImportScheme++| fieldName | type | required | description |+|--------------------|-----------|----------|---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------|+| qualified | Qualified | yes | Description of ways the import can be qualified, or not. |+| `alias` | string | no | Controls if and what alias can be used as part of an import scheme. This is the part of an import that comes after the `as` keyword, such as "Foo" in `import UnliftIO as Foo`. |+| `packageQualified` | string | no | Controls if and what package qualifier should be used. Most users are not expected to need this option. |+| `safe` | boolean | no | Controls if the import is required to use the `safe` keyword. Most users are not expected to need this option. |+| `note` | string | no | User defined message to be displayed with errors for additional context. |++#### Qualified++| fieldName | type | required | description |+|-----------------|---------|----------|-------------------------------------------------------------------------------------|+| `qualifiedPre` | boolean | no | Describes if import can be qualified prepositive like `import qualified UnliftIO`. |+| `qualifiedPost` | boolean | no | Describes if import can be qualified postpositive like `import UnliftIO qualified`. |+| `unqualified` | boolean | no | Describes if import can be unqualified like `import UnliftIO`. |++#### TreeDependency++| fieldName | type | required | description |+|----------------|-----------------|----------|-------------|+| `moduleTree` | string | yes | The tree which depends on others. |+| `dependencies` | array of string | yes | The trees which are depended upon. |+| `note` | string | no | User defined message to be displayed with errors for additional context. |++#### RulesToIgnore++This is allowed to take two forms that are both TOML tables.++##### First form++| fieldName | type | required | description |+|-----------|---------|----------|--------------------------------------------|+| `all` | boolean | no | Controls if *all* rules should be ignored. |++##### Second form++| fieldName | type | required | description |+|--------------------------------------------|---------|----------|-----------------------------------------|+| `allowedAliasUniqueness` | boolean | no | Controls if the rule should be ignored. |+| `allowedOpenUnaliasedImports` | boolean | no | Controls if the rule should be ignored. |+| `allowedQualifications` | boolean | no | Controls if the rule should be ignored. |+| `encapsulatedTrees` | boolean | no | Controls if the rule should be ignored. |+| `maximumExportsPlusHeaderUndocumented` | boolean | no | Controls if the rule should be ignored. |+| `minimumExportsPlusHeaderDocumented` | boolean | no | Controls if the rule should be ignored. |+| `maximumExportsWithoutSince` | boolean | no | Controls if the rule should be ignored. |+| `minimumExportsWithSince` | boolean | no | Controls if the rule should be ignored. |+| `moduleHeaderCopyrightMustExistNonEmpty` | boolean | no | Controls if the rule should be ignored. |+| `moduleHeaderDescriptionMustExistNonEmpty` | boolean | no | Controls if the rule should be ignored. |+| `moduleHeaderLicenseMustExistNonEmpty` | boolean | no | Controls if the rule should be ignored. |+| `moduleHeaderMaintainerMustExistNonEmpty` | boolean | no | Controls if the rule should be ignored. |+| `treeDependencies` | boolean | no | Controls if the rule should be ignored. |
+ Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple++main = defaultMain
+ henforcer.cabal view
@@ -0,0 +1,177 @@+cabal-version: 3.4++name: henforcer+version: 1.0.0.0+synopsis: GHC plugin to enforce user specified rules on code.+description: Please see the README on GitHub at <https://github.com/flipstone/henforcer#readme>+category: Development, Compiler Plugin, static-analysis+homepage: https://github.com/flipstone/henforcer#readme+bug-reports: https://github.com/flipstone/henforcer/issues+author: Flipstone Technology Partners+maintainer: maintainers@flipstone.com+copyright: 2020-2026 Flipstone Technology Partners+license: MIT+license-file: LICENSE+build-type: Simple+extra-source-files:+ README.md+extra-doc-files:+ ChangeLog.md++tested-with: GHC == 9.4.8, GHC == 9.6.7, GHC == 9.8.4, GHC == 9.10.3, GHC == 9.12.2, GHC == 9.14.1++source-repository head+ type: git+ location: https://github.com/flipstone/henforcer++flag ci+ description: More strict ghc options used for development and ci, not intended for end-use.+ manual: True+ default: False++common ci-warnings+ ghc-options:+ -Wall+ -Wcompat+ -Werror+ -Wmissing-import-lists+ -Wmissing-export-lists+ -Wmissing-home-modules+ -Wmissed-specialisations+ -Wmonomorphism-restriction+ -Wpartial-fields+ -Wcpp-undef+ -Wredundant-constraints+ -Wredundant-strictness-flags+ -Wmissing-local-signatures+ -Wunused-packages+ -Wunused-matches+ -Wunused-type-patterns+ -Winvalid-haddock+ -Wredundant-bang-patterns+ -Wimplicit-lift+ -Woperator-whitespace+ -Wredundant-strictness-flags+ -fwrite-ide-info+ if impl (ghc >= 9.8)+ ghc-options:+ -Wincomplete-export-warnings+ -Wimplicit-rhs-quantification+ -Wterm-variable-capture+ if impl (ghc >= 9.10) && impl (ghc < 9.14)+ ghc-options:+ -Wdeprecated-type-abstractions+ if impl (ghc >= 9.10)+ ghc-options:+ -Wdefaulted-exception-context+ if impl (ghc >= 9.12)+ ghc-options:+ -Wview-pattern-signatures++library henforcer-internal+ exposed-modules:+ CompatGHC+ Henforcer.Checks+ Henforcer.CodeStructure+ Henforcer.Config+ Henforcer.Options+ Henforcer.Rules+ other-modules:+ Paths_henforcer+ Henforcer.Checks.DocumentationCheck+ Henforcer.Checks.ImportCheck+ Henforcer.Checks.ImportCheck.Check+ Henforcer.Checks.ImportCheck.CheckFailure+ Henforcer.CodeStructure.Import+ Henforcer.CodeStructure.Import.AllowedAliasUniqueness+ Henforcer.CodeStructure.Import.Import+ Henforcer.CodeStructure.Import.Scheme+ Henforcer.CodeStructure.Import.Scheme.Alias+ Henforcer.CodeStructure.Import.Scheme.PackageQualifier+ Henforcer.CodeStructure.Import.Scheme.Safe+ Henforcer.CodeStructure.Import.Scheme.Scheme+ Henforcer.CodeStructure.ModuleTree+ Henforcer.Config.Config+ Henforcer.Config.ForAnyModule+ Henforcer.Config.ForPatternModule+ Henforcer.Config.ForSpecifiedModule+ Henforcer.Config.IgnoreRules+ Henforcer.Config.TreeDependencies+ Henforcer.Rules.ConditionallyEnforced+ Henforcer.Rules.Maximum+ Henforcer.Rules.Minimum+ Henforcer.Rules.MustExistNonEmpty+ Henforcer.Rules.UserNote+ TomlHelper++ autogen-modules:+ Paths_henforcer+ hs-source-dirs:+ src++ if flag(ci)+ import: ci-warnings++ ghc-options:+ -funbox-strict-fields+ -O2++ build-depends:+ base >=4.17 && <5+ , containers >=0.6 && < 0.9+ , dlist >=1.0 && <1.1+ , filepattern >=0.1 && <0.2+ , ghc >= 9.4.1 && <9.15+ , optparse-applicative >=0.14 && <0.20+ , pollock >= 0.1.0.1 && <0.2+ , text >=1.2 && <2.2+ , tomland >= 1.3.3.2 && < 1.4+ default-language: Haskell2010++library+ exposed-modules:+ Henforcer+ hs-source-dirs:+ plugin++ if flag(ci)+ import: ci-warnings++ ghc-options:+ -funbox-strict-fields+ -O2++ build-depends:+ henforcer:henforcer-internal+ , base >=4.7 && <5+ , pollock >= 0.1.0.1 && <0.2++ default-language: Haskell2010++test-suite spec+ type: exitcode-stdio-1.0+ main-is: Main.hs+ hs-source-dirs:+ test++ other-modules:+ Test.Config+ Test.Config.Documentation+ Test.Config.Import++ ghc-options:+ -threaded+ -rtsopts+ -with-rtsopts=-N+ if flag(ci)+ import: ci-warnings++ build-depends:+ base >=4.7 && <5+ , containers >=0.6 && < 0.9+ , henforcer:henforcer-internal+ , hedgehog >= 1.2 && < 1.8+ , tasty >= 1.4 && < 1.6+ , tasty-hedgehog >= 1.4 && < 1.5++ default-language: Haskell2010
+ plugin/Henforcer.hs view
@@ -0,0 +1,99 @@+{- |+Module : Henforcer+Description :+Copyright : (c) Flipstone Technology Partners, 2023-2026+License : MIT+Maintainer : maintainers@flipstone.com+-}+module Henforcer+ ( plugin+ ) where++import qualified Control.Concurrent.MVar as MVar+import qualified Pollock+import qualified System.IO.Unsafe as UnsafeIO++import qualified CompatGHC+import qualified Henforcer.Checks as Checks+import qualified Henforcer.Config as Config+import qualified Henforcer.Options as Options++plugin :: CompatGHC.Plugin+plugin =+ CompatGHC.defaultPlugin+ { CompatGHC.pluginRecompile = recompile+ , CompatGHC.renamedResultAction = CompatGHC.keepRenamedSource+ , CompatGHC.typeCheckResultAction = typeCheckResultAction+ , CompatGHC.driverPlugin = Pollock.ensureHaddockIsOn+ }++-- Using an MVar and unsafePerformIO here is a very ugly hack, but the plugin interface gives us no+-- way to load the configuration once for the entire set of modules being compiled. This is a big+-- enough performance win that the cost seems likely worth it otherwise.+globalConfigState :: MVar.MVar (Config.Config, CompatGHC.Fingerprint)+{-# NOINLINE globalConfigState #-}+globalConfigState = UnsafeIO.unsafePerformIO MVar.newEmptyMVar++{- | During typechecking is when Henforcer performs checks, adding any violations to the error+messages tracked by GHC.+-}+typeCheckResultAction ::+ [CompatGHC.CommandLineOption]+ -> CompatGHC.ModSummary+ -> CompatGHC.TcGblEnv+ -> CompatGHC.TcM CompatGHC.TcGblEnv+typeCheckResultAction commandLineOpts _modSummary tcGblEnv = do+ config <- CompatGHC.liftIO $ loadConfigIfNeeded commandLineOpts+ let+ modName = CompatGHC.moduleName $ CompatGHC.tcg_mod tcGblEnv++ CompatGHC.addMessages+ . Checks.errorMessagesFromList+ $ Checks.checkImports (Checks.determineChecks config modName) tcGblEnv++ pollockModuleInfo <- CompatGHC.liftIO $ Pollock.processModule tcGblEnv++ CompatGHC.addMessages+ . Checks.docErrorMessagesFromList+ $ Checks.checkDocumentation (Checks.determineDocumentationChecks config modName) pollockModuleInfo++ pure tcGblEnv++{- | Determines if recompilation of previous modules should happen. This always gets the fingerprint+of the configuration so that a cached version does not conflict with the recompilation checks.+-}+recompile :: [CompatGHC.CommandLineOption] -> IO CompatGHC.PluginRecompile+recompile =+ fmap (CompatGHC.MaybeRecompile . snd) . getConfigPathAndFingerprint++-- | Load the config into the global state, if it isn't there.+loadConfigIfNeeded :: [CompatGHC.CommandLineOption] -> IO Config.Config+loadConfigIfNeeded commandLineOpts = do+ mbConfigWithFingerprint <- MVar.tryReadMVar globalConfigState+ case mbConfigWithFingerprint of+ Just (conf, mvarFingerprint) -> do+ (configPath, currentFingerprint) <- getConfigPathAndFingerprint commandLineOpts+ -- A small optimization here, if the fingerprint is unchanged we do not need to reload the+ -- config. If it has changed then make sure to reload the config.+ if currentFingerprint == mvarFingerprint+ then pure conf+ else do+ loadedConfig <- Config.loadConfig configPath+ _ <- MVar.tryPutMVar globalConfigState (loadedConfig, currentFingerprint)+ pure loadedConfig+ Nothing -> do+ (configPath, currentFingerprint) <- getConfigPathAndFingerprint commandLineOpts+ loadedConfig <- Config.loadConfig configPath+ -- If we've been beaten to filling the global config, then oh well, but we do not want to+ -- block on it.+ _ <- MVar.tryPutMVar globalConfigState (loadedConfig, currentFingerprint)+ pure loadedConfig++{- | Parse the command line options for the path to the config and compute the fingerprint of that+config.+-}+getConfigPathAndFingerprint :: [CompatGHC.CommandLineOption] -> IO (FilePath, CompatGHC.Fingerprint)+getConfigPathAndFingerprint commandLineOpts = do+ configPath <- fmap Options.configPath $ Options.parseGivenOptions commandLineOpts+ fingerprint <- CompatGHC.getFileHash configPath+ pure (configPath, fingerprint)
+ src/CompatGHC.hs view
@@ -0,0 +1,296 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -Wno-missing-import-lists #-}+{-# OPTIONS_GHC -Wno-orphans -Wno-missing-methods #-}+#if __GLASGOW_HASKELL__ == 904+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+#else+{-# LANGUAGE TypeOperators #-}+#endif++{- |+Module : CompatGHC+Description : This collects all of the imports from GHC to limit the need to handle multiple versions to only this module. The intent is for the rest of the code to never import from GHC directly but use this as the interface. As such this both re-exports from GHC, and creates some helper functions to generally ease development.+Copyright : (c) Flipstone Technology Partners, 2023-2026+License : MIT+Maintainer : maintainers@flipstone.com+-}+module CompatGHC+ ( -- GHC+ GhcRn+ , IE (..)+ , ImportDecl+ , ImportDeclQualifiedStyle (..)+ , LIE+ , LImportDecl+ , ModSummary (..)+ , ModuleName+ , SrcSpan+ , generatedSrcSpan+ , getLoc+ , ideclAs+ , ideclName+ , ideclPkgQual+ , ideclQualified+ , ideclSafe+ , ideclImportList+ , locA+ , mkModuleName+ , moduleName+ , moduleNameString+ , unLoc+ -- GHC.Data.Bag+ , Bag+ , listToBag+ -- GHC.Fingerprint+ , Fingerprint+ , getFileHash+ -- GHC.Plugins+ , CommandLineOption+ , DiagnosticReason (..)+ , Messages+ , Outputable (ppr)+ , Plugin (..)+ , PluginRecompile (MaybeRecompile)+ , SDoc+ , TcGblEnv (tcg_rn_exports, tcg_rn_imports, tcg_mod)+ , TcM+ , UnitId (..)+ , blankLine+ , cat+ , colon+ , defaultPlugin+ , dot+ , doubleQuotes+ , empty+ , hang+ , hsep+ , liftIO+ , purePlugin+ , sep+ , text+ , vcat+ , unitIdString+ , neverQualify+ , keepRenamedSource+ -- GHC.Types.Error+ , Diagnostic (..)+ , DiagnosticCode (..)+ , MsgEnvelope+ , mkSimpleDecorated+ , mkDecorated+ , NoDiagnosticOpts (NoDiagnosticOpts)+ , mkMessages+ -- internal defined helpers+ , PkgQual (..)+ , addMessages+ , mkErrorMsgEnvelope+ , moduleNameCodec+ , moduleNameListCodec+ , mkHenforcerDiagnosticCode+ ) where++import qualified Data.Text as T+import Data.Typeable (Typeable)+import GHC+ ( GhcRn+ , IE (..)+ , ImportDecl+ , ImportDeclQualifiedStyle (..)+ , LIE+ , LImportDecl+ , ModSummary (..)+ , ModuleName+ , PkgQual (..)+ , SrcSpan+ , getLoc+ , ideclAs+ , ideclName+ , ideclPkgQual+ , ideclQualified+ , ideclSafe+ , locA+ , mkModuleName+ , moduleName+ , moduleNameString+ , unLoc+ )+import GHC.Data.Bag (Bag, listToBag)+import qualified GHC.Data.Bag as GHC+import GHC.Fingerprint (Fingerprint, getFileHash)+import GHC.Plugins+ ( CommandLineOption+ , DiagnosticReason (..)+ , Messages+ , Outputable (ppr)+ , Plugin (..)+ , PluginRecompile (MaybeRecompile)+ , SDoc+ , UnitId (..)+ , blankLine+ , cat+ , colon+ , defaultPlugin+ , dot+ , doubleQuotes+ , empty+ , generatedSrcSpan+ , hang+ , hsep+ , keepRenamedSource+ , liftIO+ , neverQualify+ , purePlugin+ , sep+ , text+ , unitIdString+ , vcat+ )+import qualified GHC.Tc.Errors.Types as GHC+import GHC.Tc.Utils.Monad (TcGblEnv (tcg_mod, tcg_rn_imports), TcM)+import qualified GHC.Tc.Utils.Monad as GHC+import GHC.Types.Error (MsgEnvelope (..), mkDecorated, mkMessages, mkSimpleDecorated)+import qualified GHC.Types.Error as GHC+import qualified Numeric.Natural as Natural+import qualified Toml++#if __GLASGOW_HASKELL__ == 904+import qualified GHC+import qualified Text.Printf as Printf+#endif++#if __GLASGOW_HASKELL__ >= 906 && __GLASGOW_HASKELL__ <= 914+import GHC (ideclImportList)+import GHC.Types.Error (Diagnostic(..), NoDiagnosticOpts(NoDiagnosticOpts), DiagnosticCode(..))+import GHC.Utils.Error (mkErrorMsgEnvelope)+#endif++#if __GLASGOW_HASKELL__ == 904+data NoDiagnosticOpts = NoDiagnosticOpts++-- | The 'Diagnostic' class has seen a frustrating amount of churn, changing in every release, here+-- we model the 9.8 interface, but just enough for what we need.+class Diagnostic a where+ type DiagnosticOpts a+ diagnosticMessage :: Int -> a -> GHC.DecoratedSDoc+ diagnosticReason :: a -> DiagnosticReason+ diagnosticHints :: a -> [b]+ diagnosticCode :: a -> Maybe DiagnosticCode++-- | The actual printed form for Diagnostics in 9.4 is not exactly the same as in later versions+-- because we would have to hack in the printing of the diagnostic code, and do not have a good way+-- to make it appear the same as later versions so we omit it. This has the advantage of being+-- consistent with 9.4 not printing diagnostic codes from GHC itself, at the cost of less+-- information to our users.+instance Diagnostic a => GHC.Diagnostic a where+ diagnosticMessage = diagnosticMessage 0+ diagnosticReason = diagnosticReason+ diagnosticHints = diagnosticHints++-- | Compatibility shim as this datatype was added in GHC 9.6, which is when the error codes first started being reported.+data DiagnosticCode =+ DiagnosticCode+ { diagnosticCodeNameSpace :: String+ , diagnosticCodeNumber :: Natural.Natural+ }++-- | The instances for DiagnosticCode are made to be consistent with later GHC versions+instance Show DiagnosticCode where+ show (DiagnosticCode prefix c) =+ prefix <> "-" <> Printf.printf "%05d" c+ -- Newer GHC that include 'DiagnosticCode' pad to 5 digits. So we do the same for consistency.++instance Outputable DiagnosticCode where+ ppr code = text (show code)++-- | Compatibility shim as this datatype was added in GHC 9.6, along with 'ideclImportList' │+data ImportListInterpretation = Exactly | EverythingBut++-- | Compatibility shim as GHC 9.4 used 'ideclHiding', but later changed to 'ideclImportList'. │+ideclImportList :: ImportDecl pass -> Maybe (ImportListInterpretation, GHC.XRec pass [GHC.XRec pass (GHC.IE pass)])+ideclImportList idecl =+ case GHC.ideclHiding idecl of+ Nothing -> Nothing+ Just (True, n) -> Just (EverythingBut,n)+ Just (False,n) -> Just (Exactly,n)++-- | Helper for creating a 'MsgEnvelope' as needed for 9.4.x+mkErrorMsgEnvelope :: SrcSpan -> unused -> e -> MsgEnvelope e+mkErrorMsgEnvelope msgSpan _ a =+ MsgEnvelope+ { errMsgSpan = msgSpan+ , errMsgContext = neverQualify+ , errMsgSeverity = GHC.SevError+ , errMsgDiagnostic = a+ }++-- | Helper to add messages to the type checking monad so our plugin will print our output and fail+-- a build.+addMessages :: (Typeable a, GHC.Diagnostic a) => Messages a -> TcM ()+addMessages =+ GHC.addMessages . fmap GHC.TcRnUnknownMessage++#endif++#if __GLASGOW_HASKELL__ >= 906 && __GLASGOW_HASKELL__ <= 912+-- | Helper to add messages to the type checking monad so our plugin will print our output and fail+-- a build.+addMessages ::+ (Typeable a+ , GHC.Diagnostic a+ , GHC.DiagnosticOpts a ~ GHC.NoDiagnosticOpts+ ) =>+ Messages a ->+ TcM ()+addMessages =+ GHC.addMessages . fmap GHC.mkTcRnUnknownMessage++#endif++#if __GLASGOW_HASKELL__ >= 914+-- | Helper to add messages to the type checking monad so our plugin will print our output and fail+-- a build.+addMessages ::+ (Typeable a+ , GHC.Diagnostic a+ , GHC.DiagnosticOpts a ~ GHC.NoDiagnosticOpts+ , GHC.DiagnosticHint a ~ GHC.GhcHint+ ) =>+ Messages a ->+ TcM ()+addMessages =+ GHC.addMessages . fmap GHC.mkTcRnUnknownMessage++#endif++{- | Toml codec for 'ModuleName'. Note that the encode here may not be what is desired, but+Henforcer does not, as of this writing, actually create Toml, just consume it.+-}+moduleNameCodec :: Toml.Key -> Toml.TomlCodec ModuleName+moduleNameCodec =+ Toml.dimap show mkModuleName . Toml.string+{-# INLINEABLE moduleNameCodec #-}++moduleNameListCodec :: Toml.Key -> Toml.TomlCodec [ModuleName]+moduleNameListCodec =+ Toml.arrayOf (Toml._TextBy (T.pack . show) (pure . mkModuleName . T.unpack))+{-# INLINEABLE moduleNameListCodec #-}++instance Show ImportDeclQualifiedStyle where+ show = declStyleToStr++declStyleToStr :: ImportDeclQualifiedStyle -> String+declStyleToStr decl =+ case decl of+ QualifiedPre -> "QualifiedPre"+ QualifiedPost -> "QualifiedPost"+ NotQualified -> "NotQualified"++instance Applicative Bag where+ pure = GHC.unitBag++-- | A helper to create 'DiagnosticCode' while ensuring we _always_ use the correct prefix.+mkHenforcerDiagnosticCode :: Natural.Natural -> DiagnosticCode+mkHenforcerDiagnosticCode =+ DiagnosticCode "HEN"
+ src/Henforcer/Checks.hs view
@@ -0,0 +1,15 @@+{-# OPTIONS_GHC -Wno-missing-import-lists #-}++{- |+Module : Henforcer.Checks+Description : All of the checks Henforcer currently supports.+Copyright : (c) Flipstone Technology Partners, 2023-2026+License : MIT+Maintainer : maintainers@flipstone.com+-}+module Henforcer.Checks+ ( module Export+ ) where++import Henforcer.Checks.DocumentationCheck as Export+import Henforcer.Checks.ImportCheck as Export
+ src/Henforcer/Checks/DocumentationCheck.hs view
@@ -0,0 +1,538 @@+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -Wno-missing-methods #-}++{- |+Module : Henforcer.Checks.DocumentationCheck+Description :+Copyright : (c) Flipstone Technology Partners, 2023-2026+License : MIT+Maintainer : maintainers@flipstone.com+-}+module Henforcer.Checks.DocumentationCheck+ ( docErrorMessagesFromList+ , determineDocumentationChecks+ , checkDocumentation+ , DocumentationChecks (..)+ ) where++import qualified Data.List as List+import qualified Data.Maybe as Maybe+import qualified Pollock++import qualified CompatGHC+import qualified Henforcer.Config as Config+import qualified Henforcer.Rules as Rules++data DocumentationChecks = DocumentationChecks+ { maximumUndocumentedExports :: !Rules.MaximumAllowed+ , minimumDocumentedExports :: !Rules.MinimumAllowed+ , maximumExportsWithoutSince :: !Rules.MaximumAllowed+ , minimumExportsWithSince :: !Rules.MinimumAllowed+ , moduleHeaderCopyrightMustExistNonEmpty :: !Rules.MustExistNonEmpty+ , moduleHeaderDescriptionMustExistNonEmpty :: !Rules.MustExistNonEmpty+ , moduleHeaderLicenseMustExistNonEmpty :: !Rules.MustExistNonEmpty+ , moduleHeaderMaintainerMustExistNonEmpty :: !Rules.MustExistNonEmpty+ }+ deriving (Eq, Show)++instance CompatGHC.Outputable CheckFailure where+ ppr cf =+ case cf of+ OverMaximumUndocumented current rule -> formatOverMaximumUndocumentedViolation current rule+ UnderMinimumDocumented current rule -> formatUnderMinimumDocumentedViolation current rule+ OverMaximumWithoutSince current rule -> formatOverMaximumWithoutSinceViolation current rule+ UnderMinimumWithSince current rule -> formatUnderMinimumWithSinceViolation current rule+ CopyrightMustBeNonEmpty ->+ formatMustBeNonEmpty "copyright"+ DescriptionMustBeNonEmpty ->+ formatMustBeNonEmpty "description"+ LicenseMustBeNonEmpty ->+ formatMustBeNonEmpty "license"+ MaintainerMustBeNonEmpty ->+ formatMustBeNonEmpty "maintainer"++{- | The only part of the 'CompatGHC.Diagnostic' class that we really care about is the+ 'diagnosticMessage', used for printing.+-}+instance CompatGHC.Diagnostic CheckFailure where+ type DiagnosticOpts CheckFailure = CompatGHC.NoDiagnosticOpts+ diagnosticMessage _ = CompatGHC.mkSimpleDecorated . CompatGHC.ppr+ diagnosticReason = const CompatGHC.ErrorWithoutFlag+ diagnosticHints = const mempty+ diagnosticCode = Just . checkFailureDiagnosticCode++data CheckFailure+ = OverMaximumUndocumented !Rules.MaximumNat !Rules.MaximumNat+ | UnderMinimumDocumented !Rules.MinimumNat !Rules.MinimumNat+ | OverMaximumWithoutSince !Rules.MaximumNat !Rules.MaximumNat+ | UnderMinimumWithSince !Rules.MinimumNat !Rules.MinimumNat+ | CopyrightMustBeNonEmpty+ | DescriptionMustBeNonEmpty+ | LicenseMustBeNonEmpty+ | MaintainerMustBeNonEmpty++checkFailureDiagnosticCode :: CheckFailure -> CompatGHC.DiagnosticCode+checkFailureDiagnosticCode cf =+ CompatGHC.mkHenforcerDiagnosticCode $+ case cf of+ OverMaximumUndocumented _ _ -> 95002+ UnderMinimumDocumented _ _ -> 73921+ OverMaximumWithoutSince _ _ -> 6782+ UnderMinimumWithSince _ _ -> 80933+ CopyrightMustBeNonEmpty -> 46651+ DescriptionMustBeNonEmpty -> 40311+ LicenseMustBeNonEmpty -> 12664+ MaintainerMustBeNonEmpty -> 88664++formatUnderMinimumDocumentedViolation ::+ Rules.MinimumNat -> Rules.MinimumNat -> CompatGHC.SDoc+formatUnderMinimumDocumentedViolation current rule =+ let beginningDoc =+ CompatGHC.sep+ [ CompatGHC.hsep+ [ CompatGHC.text "There were not enough documented exports."+ ]+ , CompatGHC.hsep+ [ CompatGHC.text "The minimum allowed is:"+ , CompatGHC.ppr rule+ ]+ , CompatGHC.hsep+ [ CompatGHC.text "The number documented is:"+ , CompatGHC.ppr current+ ]+ ]+ in CompatGHC.vcat+ [ beginningDoc+ , CompatGHC.blankLine+ ]++formatOverMaximumUndocumentedViolation ::+ Rules.MaximumNat -> Rules.MaximumNat -> CompatGHC.SDoc+formatOverMaximumUndocumentedViolation current rule =+ let beginningDoc =+ CompatGHC.sep+ [ CompatGHC.hsep+ [ CompatGHC.text "There were too many undocumented exports."+ ]+ , CompatGHC.hsep+ [ CompatGHC.text "The maximum allowed is:"+ , CompatGHC.ppr rule+ ]+ , CompatGHC.hsep+ [ CompatGHC.text "The number undocumented is:"+ , CompatGHC.ppr current+ ]+ ]+ in CompatGHC.vcat+ [ beginningDoc+ , CompatGHC.blankLine+ ]++formatOverMaximumWithoutSinceViolation ::+ Rules.MaximumNat -> Rules.MaximumNat -> CompatGHC.SDoc+formatOverMaximumWithoutSinceViolation current rule =+ let beginningDoc =+ CompatGHC.sep+ [ CompatGHC.hsep+ [ CompatGHC.text "There were too many exports without an @since haddock annotation."+ ]+ , CompatGHC.hsep+ [ CompatGHC.text "The maximum allowed is:"+ , CompatGHC.ppr rule+ ]+ , CompatGHC.hsep+ [ CompatGHC.text "The number missing the annotation is:"+ , CompatGHC.ppr current+ ]+ ]+ in CompatGHC.vcat+ [ beginningDoc+ , CompatGHC.blankLine+ ]++formatUnderMinimumWithSinceViolation ::+ Rules.MinimumNat -> Rules.MinimumNat -> CompatGHC.SDoc+formatUnderMinimumWithSinceViolation current rule =+ let beginningDoc =+ CompatGHC.sep+ [ CompatGHC.hsep+ [ CompatGHC.text "There were not enough exports with an @since haddock annotation."+ ]+ , CompatGHC.hsep+ [ CompatGHC.text "The minimum allowed is:"+ , CompatGHC.ppr rule+ ]+ , CompatGHC.hsep+ [ CompatGHC.text "The number with the annotation is:"+ , CompatGHC.ppr current+ ]+ ]+ in CompatGHC.vcat+ [ beginningDoc+ , CompatGHC.blankLine+ ]++formatMustBeNonEmpty ::+ String+ -> CompatGHC.SDoc+formatMustBeNonEmpty fieldStr =+ CompatGHC.vcat+ [ CompatGHC.sep+ [ CompatGHC.hsep+ [ CompatGHC.text ("The module header field " <> fieldStr <> " must be present and non-empty.")+ ]+ ]+ , CompatGHC.blankLine+ ]++mkEnv :: CheckFailure -> CompatGHC.MsgEnvelope CheckFailure+mkEnv = CompatGHC.mkErrorMsgEnvelope CompatGHC.generatedSrcSpan CompatGHC.neverQualify++docErrorMessagesFromList :: CompatGHC.Bag CheckFailure -> CompatGHC.Messages CheckFailure+docErrorMessagesFromList =+ CompatGHC.mkMessages . fmap mkEnv++determineDocumentationChecks ::+ Config.Config+ -> CompatGHC.ModuleName+ -> DocumentationChecks+determineDocumentationChecks config modName =+ let+ originalSpecifiedModule =+ Maybe.fromMaybe Config.emptyForSpecifiedModule+ . List.lookup modName+ $ Config.forSpecifiedModules config+ forAnyModule = Config.forAnyModule config+ patternModule =+ maybe Config.emptyForSpecifiedModule snd+ . Config.moduleMatchesPattern (CompatGHC.moduleNameString modName)+ $ Config.forPatternModules config+ forSpecifiedModule = Config.unionPatternAndSpecifiedModule patternModule originalSpecifiedModule+ in+ DocumentationChecks+ { maximumUndocumentedExports =+ determineMaxiumumUndocumentedExports forAnyModule forSpecifiedModule+ , minimumDocumentedExports =+ determineMiniumumDocumentedExports forAnyModule forSpecifiedModule+ , maximumExportsWithoutSince =+ determineMaxiumumExportsWithoutSince forAnyModule forSpecifiedModule+ , minimumExportsWithSince =+ determineMiniumumExportsWithSince forAnyModule forSpecifiedModule+ , moduleHeaderCopyrightMustExistNonEmpty =+ determineModuleHeaderCopyrightMustExistNonEmpty forAnyModule forSpecifiedModule+ , moduleHeaderDescriptionMustExistNonEmpty =+ determineModuleHeaderDescriptionMustExistNonEmpty forAnyModule forSpecifiedModule+ , moduleHeaderLicenseMustExistNonEmpty =+ determineModuleHeaderLicenseMustExistNonEmpty forAnyModule forSpecifiedModule+ , moduleHeaderMaintainerMustExistNonEmpty =+ determineModuleHeaderMaintainerMustExistNonEmpty forAnyModule forSpecifiedModule+ }++determineMaxiumumUndocumentedExports ::+ Config.ForAnyModule+ -> Config.ForSpecifiedModule+ -> Rules.MaximumAllowed+determineMaxiumumUndocumentedExports forAnyModule forSpecifiedModule =+ let+ shouldBeIgnored =+ maybe False (Config.isRuleIgnored Config.ignoreRulesMaximumUndocumentedExports) $+ Config.specifiedModuleRulesToIgnore forSpecifiedModule+ in+ if shouldBeIgnored+ then Rules.NotEnforced+ else+ Maybe.fromMaybe+ (Config.anyModuleMaximumUndocumentedExports forAnyModule)+ (Config.specifiedModuleMaximumUndocumentedExports forSpecifiedModule)++determineMiniumumDocumentedExports ::+ Config.ForAnyModule+ -> Config.ForSpecifiedModule+ -> Rules.MinimumAllowed+determineMiniumumDocumentedExports forAnyModule forSpecifiedModule =+ let+ shouldBeIgnored =+ maybe False (Config.isRuleIgnored Config.ignoreRulesMinimumDocumentedExports) $+ Config.specifiedModuleRulesToIgnore forSpecifiedModule+ in+ if shouldBeIgnored+ then Rules.NotEnforced+ else+ Maybe.fromMaybe+ (Config.anyModuleMinimumDocumentedExports forAnyModule)+ (Config.specifiedModuleMinimumDocumentedExports forSpecifiedModule)++determineMaxiumumExportsWithoutSince ::+ Config.ForAnyModule+ -> Config.ForSpecifiedModule+ -> Rules.MaximumAllowed+determineMaxiumumExportsWithoutSince forAnyModule forSpecifiedModule =+ let+ shouldBeIgnored =+ maybe False (Config.isRuleIgnored Config.ignoreRulesMaximumExportsWithoutSince) $+ Config.specifiedModuleRulesToIgnore forSpecifiedModule+ in+ if shouldBeIgnored+ then Rules.NotEnforced+ else+ Maybe.fromMaybe+ (Config.anyModuleMaximumExportsWithoutSince forAnyModule)+ (Config.specifiedModuleMaximumExportsWithoutSince forSpecifiedModule)++determineMiniumumExportsWithSince ::+ Config.ForAnyModule+ -> Config.ForSpecifiedModule+ -> Rules.MinimumAllowed+determineMiniumumExportsWithSince forAnyModule forSpecifiedModule =+ let+ shouldBeIgnored =+ maybe False (Config.isRuleIgnored Config.ignoreRulesMinimumExportsWithSince) $+ Config.specifiedModuleRulesToIgnore forSpecifiedModule+ in+ if shouldBeIgnored+ then Rules.NotEnforced+ else+ Maybe.fromMaybe+ (Config.anyModuleMinimumExportsWithSince forAnyModule)+ (Config.specifiedModuleMinimumExportsWithSince forSpecifiedModule)++determineModuleHeaderCopyrightMustExistNonEmpty ::+ Config.ForAnyModule+ -> Config.ForSpecifiedModule+ -> Rules.MustExistNonEmpty+determineModuleHeaderCopyrightMustExistNonEmpty forAnyModule forSpecifiedModule =+ let+ shouldBeIgnored =+ maybe False (Config.isRuleIgnored Config.ignoreRulesModuleHeaderCopyrightMustExistNonEmpty) $+ Config.specifiedModuleRulesToIgnore forSpecifiedModule+ in+ if shouldBeIgnored+ then Rules.NotEnforced+ else+ Maybe.fromMaybe+ (Config.anyModuleModuleHeaderCopyrightMustExistNonEmpty forAnyModule)+ (Config.specifiedModuleModuleHeaderCopyrightMustExistNonEmpty forSpecifiedModule)++determineModuleHeaderDescriptionMustExistNonEmpty ::+ Config.ForAnyModule+ -> Config.ForSpecifiedModule+ -> Rules.MustExistNonEmpty+determineModuleHeaderDescriptionMustExistNonEmpty forAnyModule forSpecifiedModule =+ let+ shouldBeIgnored =+ maybe False (Config.isRuleIgnored Config.ignoreRulesModuleHeaderDescriptionMustExistNonEmpty) $+ Config.specifiedModuleRulesToIgnore forSpecifiedModule+ in+ if shouldBeIgnored+ then Rules.NotEnforced+ else+ Maybe.fromMaybe+ (Config.anyModuleModuleHeaderDescriptionMustExistNonEmpty forAnyModule)+ (Config.specifiedModuleModuleHeaderDescriptionMustExistNonEmpty forSpecifiedModule)++determineModuleHeaderLicenseMustExistNonEmpty ::+ Config.ForAnyModule+ -> Config.ForSpecifiedModule+ -> Rules.MustExistNonEmpty+determineModuleHeaderLicenseMustExistNonEmpty forAnyModule forSpecifiedModule =+ let+ shouldBeIgnored =+ maybe False (Config.isRuleIgnored Config.ignoreRulesModuleHeaderLicenseMustExistNonEmpty) $+ Config.specifiedModuleRulesToIgnore forSpecifiedModule+ in+ if shouldBeIgnored+ then Rules.NotEnforced+ else+ Maybe.fromMaybe+ (Config.anyModuleModuleHeaderLicenseMustExistNonEmpty forAnyModule)+ (Config.specifiedModuleModuleHeaderLicenseMustExistNonEmpty forSpecifiedModule)++determineModuleHeaderMaintainerMustExistNonEmpty ::+ Config.ForAnyModule+ -> Config.ForSpecifiedModule+ -> Rules.MustExistNonEmpty+determineModuleHeaderMaintainerMustExistNonEmpty forAnyModule forSpecifiedModule =+ let+ shouldBeIgnored =+ maybe False (Config.isRuleIgnored Config.ignoreRulesModuleHeaderMaintainerMustExistNonEmpty) $+ Config.specifiedModuleRulesToIgnore forSpecifiedModule+ in+ if shouldBeIgnored+ then Rules.NotEnforced+ else+ Maybe.fromMaybe+ (Config.anyModuleModuleHeaderMaintainerMustExistNonEmpty forAnyModule)+ (Config.specifiedModuleModuleHeaderMaintainerMustExistNonEmpty forSpecifiedModule)++checkDocumentation ::+ (Applicative m, Monoid (m CheckFailure)) =>+ DocumentationChecks+ -> Pollock.ModuleInfo+ -> m CheckFailure+checkDocumentation checks pollockModInfo =+ let+ undocumentedChecks =+ checkUndocumented+ (maximumUndocumentedExports checks)+ pollockModInfo+ documentedChecks =+ checkDocumented+ (minimumDocumentedExports checks)+ pollockModInfo+ withoutSinceChecks =+ checkWithoutSince+ (maximumExportsWithoutSince checks)+ pollockModInfo+ withSinceChecks =+ checkWithSince+ (minimumExportsWithSince checks)+ pollockModInfo+ withCopyrightChecks =+ checkModuleHeaderCopyright+ (moduleHeaderCopyrightMustExistNonEmpty checks)+ pollockModInfo+ withDescriptionChecks =+ checkModuleHeaderDescription+ (moduleHeaderDescriptionMustExistNonEmpty checks)+ pollockModInfo+ withLicenseChecks =+ checkModuleHeaderLicense+ (moduleHeaderLicenseMustExistNonEmpty checks)+ pollockModInfo+ withMaintainerChecks =+ checkModuleHeaderMaintainer+ (moduleHeaderMaintainerMustExistNonEmpty checks)+ pollockModInfo+ in+ undocumentedChecks+ <> documentedChecks+ <> withoutSinceChecks+ <> withSinceChecks+ <> withCopyrightChecks+ <> withDescriptionChecks+ <> withLicenseChecks+ <> withMaintainerChecks++checkUndocumented ::+ (Applicative m, Monoid (m CheckFailure)) =>+ Rules.MaximumAllowed+ -> Pollock.ModuleInfo+ -> m CheckFailure+checkUndocumented maximumAllowed pollockModInfo =+ let+ getUndocumented :: Pollock.ModuleInfo -> Rules.MaximumNat+ getUndocumented x = fromIntegral $ Pollock.haddockableExports x - Pollock.haddockedExports x+ in+ Rules.checkMaximum+ maximumAllowed+ pollockModInfo+ getUndocumented+ (OverMaximumUndocumented . getUndocumented)++checkDocumented ::+ (Applicative m, Monoid (m CheckFailure)) =>+ Rules.MinimumAllowed+ -> Pollock.ModuleInfo+ -> m CheckFailure+checkDocumented minimumAllowed pollockModInfo =+ let+ getDocumentedNat :: Pollock.ModuleInfo -> Rules.MinimumNat+ getDocumentedNat = fromIntegral . Pollock.haddockedExports+ in+ Rules.checkMinimum+ minimumAllowed+ pollockModInfo+ getDocumentedNat+ (UnderMinimumDocumented . getDocumentedNat)++checkWithoutSince ::+ (Applicative m, Monoid (m CheckFailure)) =>+ Rules.MaximumAllowed+ -> Pollock.ModuleInfo+ -> m CheckFailure+checkWithoutSince maximumAllowed pollockModInfo =+ let+ numWithoutSinceNat :: Pollock.ModuleInfo -> Rules.MaximumNat+ numWithoutSinceNat x = fromIntegral $ Pollock.haddockableExports x - Pollock.numWithSince x+ in+ Rules.checkMaximum+ maximumAllowed+ pollockModInfo+ numWithoutSinceNat+ (OverMaximumWithoutSince . numWithoutSinceNat)++checkWithSince ::+ (Applicative m, Monoid (m CheckFailure)) =>+ Rules.MinimumAllowed+ -> Pollock.ModuleInfo+ -> m CheckFailure+checkWithSince minimumAllowed pollockModInfo =+ let+ numWithSinceNat :: Pollock.ModuleInfo -> Rules.MinimumNat+ numWithSinceNat = fromIntegral . Pollock.numWithSince+ in+ Rules.checkMinimum+ minimumAllowed+ pollockModInfo+ numWithSinceNat+ (UnderMinimumWithSince . numWithSinceNat)++checkModuleHeaderCopyright ::+ (Applicative m, Monoid (m CheckFailure)) =>+ Rules.MustExistNonEmpty+ -> Pollock.ModuleInfo+ -> m CheckFailure+checkModuleHeaderCopyright copyrightMustExist pollockModInfo =+ let+ getCopyright = Pollock.copyright . Pollock.moduleHeader+ in+ Rules.checkExistsAndNonEmptyString+ copyrightMustExist+ pollockModInfo+ getCopyright+ (const CopyrightMustBeNonEmpty)++checkModuleHeaderDescription ::+ (Applicative m, Monoid (m CheckFailure)) =>+ Rules.MustExistNonEmpty+ -> Pollock.ModuleInfo+ -> m CheckFailure+checkModuleHeaderDescription descriptionMustExist pollockModInfo =+ let+ getDescription = Pollock.description . Pollock.moduleHeader+ in+ Rules.checkExistsAndNonEmptyString+ descriptionMustExist+ pollockModInfo+ getDescription+ (const DescriptionMustBeNonEmpty)++checkModuleHeaderLicense ::+ (Applicative m, Monoid (m CheckFailure)) =>+ Rules.MustExistNonEmpty+ -> Pollock.ModuleInfo+ -> m CheckFailure+checkModuleHeaderLicense licenseMustExist pollockModInfo =+ let+ getLicense = Pollock.license . Pollock.moduleHeader+ in+ Rules.checkExistsAndNonEmptyString+ licenseMustExist+ pollockModInfo+ getLicense+ (const LicenseMustBeNonEmpty)++checkModuleHeaderMaintainer ::+ (Applicative m, Monoid (m CheckFailure)) =>+ Rules.MustExistNonEmpty+ -> Pollock.ModuleInfo+ -> m CheckFailure+checkModuleHeaderMaintainer maintainerMustExist pollockModInfo =+ let+ getMaintainer = Pollock.maintainer . Pollock.moduleHeader+ in+ Rules.checkExistsAndNonEmptyString+ maintainerMustExist+ pollockModInfo+ getMaintainer+ (const MaintainerMustBeNonEmpty)
+ src/Henforcer/Checks/ImportCheck.hs view
@@ -0,0 +1,15 @@+{-# OPTIONS_GHC -Wno-missing-import-lists #-}++{- |+Module : Henforcer.Checks.ImportCheck+Description : Checks for imports, and ways they could fail.+Copyright : (c) Flipstone Technology Partners, 2023-2026+License : MIT+Maintainer : maintainers@flipstone.com+-}+module Henforcer.Checks.ImportCheck+ ( module Export+ ) where++import Henforcer.Checks.ImportCheck.Check as Export+import Henforcer.Checks.ImportCheck.CheckFailure as Export
+ src/Henforcer/Checks/ImportCheck/Check.hs view
@@ -0,0 +1,367 @@+{- |+Module : Henforcer.Checks.ImportCheck.Check+Description :+Copyright : (c) Flipstone Technology Partners, 2023-2026+License : MIT+Maintainer : maintainers@flipstone.com+-}+module Henforcer.Checks.ImportCheck.Check+ ( checkImports+ , determineChecks+ , ImportChecks (..)+ ) where++import qualified Control.Monad as Monad+import qualified Data.DList as DList+import qualified Data.List as List+import qualified Data.List.NonEmpty as NEL+import qualified Data.Map.Strict as Map+import qualified Data.Maybe as Maybe++import qualified CompatGHC+import Henforcer.Checks.ImportCheck.CheckFailure+ ( CheckFailure+ ( AliasUniquenessViolation+ , DependencyViolation+ , EncapsulationViolation+ , OpenImportViolation+ , QualificationViolation+ )+ , CheckFailureWithNote+ , CheckedDependency (CheckedDependency, dependencyNote, dependencySource, dependencyTarget)+ )+import qualified Henforcer.CodeStructure as CodeStructure+import qualified Henforcer.Config as Config+import qualified Henforcer.Rules as Rules++checkImports ::+ ImportChecks+ -> CompatGHC.TcGblEnv+ -> CompatGHC.Bag CheckFailureWithNote+checkImports checks tcGblEnv =+ let+ imports = CodeStructure.getImports tcGblEnv+ accumulatedResults = foldr (checkImport checks) (ImportCheckAccum mempty mempty mempty) imports+ openUnaliasedResults =+ fmap Rules.failureWithNoNote+ . Maybe.catMaybes+ $ Rules.checkMaximum+ (importChecksAllowedOpenUnaliasedImports checks)+ (openUnaliasedImports accumulatedResults)+ (fromIntegral . length . DList.toList)+ (\dlist nat -> fmap (OpenImportViolation nat) . NEL.nonEmpty $ DList.toList dlist)+ aliasUniquenessResults =+ checkAllowedAliasUniquness+ (importChecksAllowedAliasUniqueness checks)+ (aliasedImportsByAliasName accumulatedResults)+ in+ CompatGHC.listToBag $+ DList.toList (failures accumulatedResults) <> openUnaliasedResults <> aliasUniquenessResults++determineChecks :: Config.Config -> CompatGHC.ModuleName -> ImportChecks+determineChecks config modName =+ let+ specifiedModule =+ Maybe.fromMaybe Config.emptyForSpecifiedModule+ . List.lookup modName+ $ Config.forSpecifiedModules config+ patternModule =+ maybe Config.emptyForSpecifiedModule snd+ . Config.moduleMatchesPattern (CompatGHC.moduleNameString modName)+ $ Config.forPatternModules config+ in+ determineChecksForModule+ (Config.forAnyModule config)+ $ Config.unionPatternAndSpecifiedModule patternModule specifiedModule++data ImportChecks = ImportChecks+ { importChecksTreeDependencies :: !(Maybe (NEL.NonEmpty CheckedDependency)) -- Nothing means we won't even check+ , importChecksEncapsulatedTrees :: !(Maybe (NEL.NonEmpty CodeStructure.ModuleTree)) -- Nothing means we won't even check+ , importChecksAllowedQualifications :: !CodeStructure.AllowedSchemes+ , importChecksAllowedOpenUnaliasedImports :: !Rules.MaximumAllowed+ , importChecksAllowedAliasUniqueness :: !(Maybe CodeStructure.AllowedAliasUniqueness)+ }+ deriving (Eq, Show)++checkImportAgainstDependency ::+ CodeStructure.Import+ -> CheckedDependency+ -> [CheckFailureWithNote]+checkImportAgainstDependency imp dep =+ let depSource = dependencySource dep+ depTarget = dependencyTarget dep++ -- If the file that contains the import belongs to the module tree that is+ -- the dependency target then we need to check wether the module being+ -- imported (the imported target) is contained in the module tree that the+ -- dependency is declared for. This is -- once a dependency is declared, we+ -- don't allow dependency targets to import modules that depend on them.+ dependencyViolated =+ CodeStructure.treeContainsModule depTarget (CodeStructure.srcModule imp)+ && CodeStructure.treeContainsModule depSource (CodeStructure.importedModule imp)+ in if dependencyViolated+ then pure . Rules.failureWithUserNote (dependencyNote dep) $ DependencyViolation imp dep+ else mempty++checkImportAgainstEncapsulation ::+ CodeStructure.Import+ -> CodeStructure.ModuleTree+ -> [CheckFailure]+checkImportAgainstEncapsulation imp encapsulatedTree =+ let+ -- If the module being imported belongs to an encapsulated module tree+ -- then it may only be directly imported from within that tree. Imports+ -- by modules outside the encapsulated tree constitute a violation.+ encapsulationViolated =+ CodeStructure.treeStrictlyContainsModule encapsulatedTree (CodeStructure.importedModule imp)+ && (not . CodeStructure.treeContainsModule encapsulatedTree $ CodeStructure.srcModule imp)+ in+ if encapsulationViolated+ then pure $ EncapsulationViolation imp encapsulatedTree+ else mempty++determineChecksForModule ::+ Config.ForAnyModule+ -> Config.ForSpecifiedModule+ -> ImportChecks+determineChecksForModule fam fsm =+ let+ in ImportChecks+ { importChecksTreeDependencies =+ determineTreeDependencies fam fsm+ , importChecksEncapsulatedTrees =+ determineEncapsulatedTrees fam fsm+ , importChecksAllowedQualifications =+ determineAllowedQualifications fam fsm+ , importChecksAllowedOpenUnaliasedImports =+ determineAllowedOpenUnaliasedImports fam fsm+ , importChecksAllowedAliasUniqueness =+ determineAllowedAliasUniqueness fam fsm+ }++determineTreeDependencies ::+ Config.ForAnyModule+ -> Config.ForSpecifiedModule+ -> Maybe (NEL.NonEmpty CheckedDependency)+determineTreeDependencies fam fsm =+ let+ shouldBeIgnored =+ maybe False (Config.isRuleIgnored Config.ignoreRulesTreeDependencies) $+ Config.specifiedModuleRulesToIgnore fsm+ explodeDependencies decl =+ fmap (CheckedDependency (Config.moduleTree decl) (Config.treeDependencyNote decl)) $+ Config.treeDependencies decl+ in+ if shouldBeIgnored+ then mempty+ else NEL.nonEmpty . concatMap explodeDependencies $ Config.anyModuleTreeDependencies fam++determineEncapsulatedTrees ::+ Config.ForAnyModule+ -> Config.ForSpecifiedModule+ -> Maybe (NEL.NonEmpty CodeStructure.ModuleTree)+determineEncapsulatedTrees fam fsm =+ let+ shouldBeIgnored =+ maybe False (Config.isRuleIgnored Config.ignoreRulesEncapsulatedTrees) $+ Config.specifiedModuleRulesToIgnore fsm+ in+ if shouldBeIgnored+ then Nothing+ else NEL.nonEmpty $ Config.anyModuleEncapsulatedTrees fam++determineAllowedOpenUnaliasedImports ::+ Config.ForAnyModule+ -> Config.ForSpecifiedModule+ -> Rules.MaximumAllowed+determineAllowedOpenUnaliasedImports fam fsm =+ let+ shouldBeIgnored =+ maybe False (Config.isRuleIgnored Config.ignoreRulesAllowedOpenUnaliasedImports) $+ Config.specifiedModuleRulesToIgnore fsm+ in+ if shouldBeIgnored+ then Rules.NotEnforced+ else+ Maybe.fromMaybe+ (Config.anyModuleAllowedOpenUnaliasedImports fam)+ (Config.specifiedModuleAllowedOpenUnaliasedImports fsm)++determineAllowedQualifications ::+ Config.ForAnyModule+ -> Config.ForSpecifiedModule+ -> CodeStructure.AllowedSchemes+determineAllowedQualifications fam fsm =+ let+ shouldBeIgnored =+ maybe False (Config.isRuleIgnored Config.ignoreRulesAllowedQualifications) $+ Config.specifiedModuleRulesToIgnore fsm+ in+ if shouldBeIgnored+ then mempty+ else case Config.specifiedModuleAllowedQualifications fsm of+ Nothing -> Config.anyModuleAllowedQualifications fam+ Just quals -> Map.union quals $ Config.anyModuleAllowedQualifications fam++determineAllowedAliasUniqueness ::+ Config.ForAnyModule+ -> Config.ForSpecifiedModule+ -> Maybe CodeStructure.AllowedAliasUniqueness+determineAllowedAliasUniqueness fam fsm =+ let+ shouldBeIgnored =+ maybe False (Config.isRuleIgnored Config.ignoreRulesAllowedAliasUniqueness) $+ Config.specifiedModuleRulesToIgnore fsm+ in+ if shouldBeIgnored+ then Nothing+ else case Config.specifiedModuleAllowedAliasUniqueness fsm of+ Nothing ->+ Config.anyModuleAllowedAliasUniqueness fam+ Just allowedAliasUniq -> Just allowedAliasUniq++data ImportCheckAccum = ImportCheckAccum+ { failures :: !(DList.DList CheckFailureWithNote)+ , openUnaliasedImports :: !(DList.DList CodeStructure.Import)+ , aliasedImportsByAliasName :: !(Map.Map CompatGHC.ModuleName [CodeStructure.Import])+ }++checkImport ::+ ImportChecks+ -> CodeStructure.Import+ -> ImportCheckAccum+ -> ImportCheckAccum+checkImport checks imp =+ encapsulationCheck+ checks+ imp+ . dependencyCheck+ checks+ imp+ . importQualificationCheck+ checks+ imp+ . mbAddOpenImport+ checks+ imp+ . addToAliasMap+ imp++encapsulationCheck ::+ ImportChecks+ -> CodeStructure.Import+ -> ImportCheckAccum+ -> ImportCheckAccum+encapsulationCheck checks imp accum =+ case importChecksEncapsulatedTrees checks of+ Nothing ->+ accum+ Just nonEmptyTrees ->+ accum+ { failures =+ DList.append (failures accum)+ . DList.fromList+ . concatMap (fmap Rules.failureWithNoNote . checkImportAgainstEncapsulation imp)+ $ NEL.toList nonEmptyTrees+ }++dependencyCheck ::+ ImportChecks+ -> CodeStructure.Import+ -> ImportCheckAccum+ -> ImportCheckAccum+dependencyCheck checks imp accum =+ case importChecksTreeDependencies checks of+ Nothing ->+ accum+ Just nonEmptyDependencies ->+ accum+ { failures =+ DList.append (failures accum)+ . DList.fromList+ . Monad.join+ . NEL.toList+ $ fmap (checkImportAgainstDependency imp) nonEmptyDependencies+ }++importQualificationCheck ::+ ImportChecks+ -> CodeStructure.Import+ -> ImportCheckAccum+ -> ImportCheckAccum+importQualificationCheck checks imp accum =+ case Map.lookup (CodeStructure.importedModule imp) (importChecksAllowedQualifications checks) of+ Nothing ->+ accum+ Just allowedSchemes ->+ let+ (schemes, notes) =+ unzip $+ fmap (\note -> (CodeStructure.underlyingScheme note, CodeStructure.schemeNote note)) allowedSchemes+ withNotes :: CheckFailure -> CheckFailureWithNote+ withNotes = Rules.failureWithUserNotes notes+ in+ if elem+ ( CodeStructure.keepOnlyPackageNameInQualifier . CodeStructure.buildScheme . CompatGHC.unLoc $+ CodeStructure.importDecl imp+ )+ schemes+ then accum+ else+ accum+ { failures =+ DList.cons (withNotes (QualificationViolation imp schemes)) (failures accum)+ }++mbAddOpenImport ::+ ImportChecks+ -> CodeStructure.Import+ -> ImportCheckAccum+ -> ImportCheckAccum+mbAddOpenImport checks imp accum =+ case importChecksAllowedOpenUnaliasedImports checks of+ Rules.NotEnforced ->+ accum+ Rules.Enforced _ ->+ if CodeStructure.importIsOpenWithNoHidingOrAlias imp+ then+ accum+ { openUnaliasedImports =+ DList.cons imp $ openUnaliasedImports accum+ }+ else accum++addToAliasMap ::+ CodeStructure.Import+ -> ImportCheckAccum+ -> ImportCheckAccum+addToAliasMap imp accum =+ case CodeStructure.alias . CodeStructure.buildScheme . CompatGHC.unLoc $ CodeStructure.importDecl imp of+ CodeStructure.WithAlias modName ->+ accum+ { aliasedImportsByAliasName =+ Map.insertWith (<>) modName (pure imp) (aliasedImportsByAliasName accum)+ }+ CodeStructure.WithoutAlias ->+ accum++checkAllowedAliasUniquness ::+ Maybe CodeStructure.AllowedAliasUniqueness+ -> Map.Map CompatGHC.ModuleName [CodeStructure.Import]+ -> [CheckFailureWithNote]+checkAllowedAliasUniquness Nothing _ = mempty+checkAllowedAliasUniquness (Just allowedUniqueness) aliasedImports =+ let+ buildUniquenessViolation ::+ Rules.UserNote -> Map.Map k [CodeStructure.Import] -> [CheckFailureWithNote]+ buildUniquenessViolation note =+ fmap (Rules.failureWithUserNote note . AliasUniquenessViolation)+ . Maybe.mapMaybe NEL.nonEmpty+ . Map.elems+ . Map.filter ((<) 1 . length)+ in+ case allowedUniqueness of+ CodeStructure.AliasesToBeUnique (CodeStructure.AliasUniquenessRequired modNames userNote) ->+ buildUniquenessViolation userNote $ Map.restrictKeys aliasedImports modNames+ CodeStructure.AllAliasesUniqueExcept (CodeStructure.AliasUniquenessExceptions modNames userNote) ->+ buildUniquenessViolation userNote $ Map.withoutKeys aliasedImports modNames
+ src/Henforcer/Checks/ImportCheck/CheckFailure.hs view
@@ -0,0 +1,261 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -Wno-missing-methods #-}++{- |+Module : Henforcer.Checks.ImportCheck.CheckFailure+Description :+Copyright : (c) Flipstone Technology Partners, 2023-2026+License : MIT+Maintainer : maintainers@flipstone.com+-}+module Henforcer.Checks.ImportCheck.CheckFailure+ ( CheckFailure (..)+ , CheckFailureWithNote+ , CheckedDependency (..)+ , errorMessagesFromList+ ) where++import qualified Data.List.NonEmpty as NEL+import qualified Data.Text as T++import qualified CompatGHC+import qualified Henforcer.CodeStructure as CodeStructure+import qualified Henforcer.Rules as Rules++data CheckedDependency = CheckedDependency+ { dependencySource :: !CodeStructure.ModuleTree+ , dependencyNote :: !Rules.UserNote+ , dependencyTarget :: !CodeStructure.ModuleTree+ }+ deriving (Eq, Show)++type CheckFailureWithNote = Rules.FailureWithUserNote CheckFailure++data CheckFailure+ = DependencyViolation !CodeStructure.Import !CheckedDependency+ | EncapsulationViolation !CodeStructure.Import !CodeStructure.ModuleTree+ | QualificationViolation !CodeStructure.Import ![CodeStructure.Scheme]+ | OpenImportViolation !Rules.MaximumNat !(NEL.NonEmpty CodeStructure.Import)+ | AliasUniquenessViolation !(NEL.NonEmpty CodeStructure.Import)++instance CompatGHC.Outputable CheckFailure where+ ppr cf =+ case cf of+ DependencyViolation i cd -> formatDependencyViolation i cd+ EncapsulationViolation i tn -> formatEncapsulationViolation i tn+ QualificationViolation i s -> formatQualificationViolation i s+ OpenImportViolation n i -> formatOpenImportViolation i n+ AliasUniquenessViolation is -> formatAliasUniquenssViolation is++checkFailureDiagnosticCode :: CheckFailure -> CompatGHC.DiagnosticCode+checkFailureDiagnosticCode cf =+ CompatGHC.mkHenforcerDiagnosticCode $+ case cf of+ DependencyViolation _ _ -> 49096+ EncapsulationViolation _ _ -> 53012+ QualificationViolation _ _ -> 12259+ OpenImportViolation _ _ -> 75306+ AliasUniquenessViolation _ -> 42555++{- | Convert a list of 'CheckFailure' to 'CompatGHC.Messages' so we can hand off to GHC printing mechanism+ in the plugin.+-}+errorMessagesFromList ::+ CompatGHC.Bag CheckFailureWithNote -> CompatGHC.Messages CheckFailureWithNote+errorMessagesFromList =+ CompatGHC.mkMessages . fmap mkEnv+{-# INLINEABLE errorMessagesFromList #-}++checkFailureImport :: CheckFailure -> CodeStructure.Import+checkFailureImport (DependencyViolation i _) = i+checkFailureImport (EncapsulationViolation i _) = i+checkFailureImport (QualificationViolation i _) = i+checkFailureImport (OpenImportViolation _ (i NEL.:| _)) = i+checkFailureImport (AliasUniquenessViolation (i NEL.:| _)) = i++checkFailureLoc :: CheckFailure -> CompatGHC.SrcSpan+checkFailureLoc = CodeStructure.srcLocation . checkFailureImport++{- | The only part of the 'CompatGHC.Diagnostic' class that we really care about is the+ 'diagnosticMessage', used for printing.+-}+instance CompatGHC.Diagnostic CheckFailureWithNote where+ type DiagnosticOpts (Rules.FailureWithUserNote CheckFailure) = CompatGHC.NoDiagnosticOpts+ diagnosticMessage _ = CompatGHC.mkSimpleDecorated . CompatGHC.ppr+ diagnosticReason = const CompatGHC.ErrorWithoutFlag+ diagnosticHints = const []+ diagnosticCode =+ Just . checkFailureDiagnosticCode . Rules.underlyingFailure++mkEnv :: CheckFailureWithNote -> CompatGHC.MsgEnvelope (Rules.FailureWithUserNote CheckFailure)+mkEnv cf =+ CompatGHC.mkErrorMsgEnvelope+ (checkFailureLoc $ Rules.underlyingFailure cf)+ CompatGHC.neverQualify+ cf++formatDependencyViolation :: CodeStructure.Import -> CheckedDependency -> CompatGHC.SDoc+formatDependencyViolation imp dep =+ CompatGHC.sep+ [ CompatGHC.hsep+ [ formatImportSubject imp+ , CompatGHC.text "is forbidden by the declaration that the module tree"+ , CompatGHC.ppr $ dependencySource dep+ , CompatGHC.text "depends on"+ , CompatGHC.ppr $ dependencyTarget dep+ ]+ , CompatGHC.blankLine+ ]++formatEncapsulationViolation :: CodeStructure.Import -> CodeStructure.ModuleTree -> CompatGHC.SDoc+formatEncapsulationViolation imp moduleTree =+ CompatGHC.sep+ [ CompatGHC.sep+ [ formatImportSubject imp+ , CompatGHC.text "is forbidden because it is an internal module of the encapsulated tree"+ , CompatGHC.ppr moduleTree+ ]+ , CompatGHC.blankLine+ ]++formatImportSubject :: CodeStructure.Import -> CompatGHC.SDoc+formatImportSubject imp =+ CompatGHC.hsep+ [ CompatGHC.text "The import of"+ , CompatGHC.ppr (CodeStructure.importedModule imp)+ ]++formatQualificationViolation :: CodeStructure.Import -> [CodeStructure.Scheme] -> CompatGHC.SDoc+formatQualificationViolation imp alloweds =+ let rebuildFromImport =+ rebuildImportStatementFromScheme (CodeStructure.importedModule imp)+ beginningDoc =+ CompatGHC.hang+ ( CompatGHC.sep+ [ CompatGHC.hsep+ [ formatImportSubject imp+ , CompatGHC.text "is improper because it does not match one of the allowed import schemes."+ ]+ , CompatGHC.cat+ [ CompatGHC.text "It was imported"+ , CompatGHC.colon+ ]+ ]+ )+ 4+ (rebuildFromImport . CodeStructure.buildScheme . CompatGHC.unLoc $ CodeStructure.importDecl imp)+ endDoc =+ CompatGHC.hang+ ( CompatGHC.cat+ [ CompatGHC.text "But it may only be imported in the followings ways"+ , CompatGHC.colon+ ]+ )+ 4+ (CompatGHC.vcat $ fmap rebuildFromImport alloweds)+ in CompatGHC.vcat+ [ beginningDoc+ , CompatGHC.blankLine+ , endDoc+ , CompatGHC.blankLine+ ]++formatOpenImportViolation ::+ NEL.NonEmpty CodeStructure.Import -> Rules.MaximumNat -> CompatGHC.SDoc+formatOpenImportViolation imps maxAllowedNat =+ let rebuildFromImport imp =+ rebuildImportStatementFromScheme (CodeStructure.importedModule imp)+ . CodeStructure.buildScheme+ . CompatGHC.unLoc+ $ CodeStructure.importDecl imp+ beginningDoc =+ CompatGHC.hang+ ( CompatGHC.sep+ [ CompatGHC.hsep+ [ CompatGHC.text "There were too many open imports. The max allowed is:"+ , CompatGHC.ppr maxAllowedNat+ ]+ , CompatGHC.cat+ [ CompatGHC.text "The open imports are"+ , CompatGHC.colon+ ]+ ]+ )+ 4+ (CompatGHC.vcat . fmap rebuildFromImport $ NEL.toList imps)+ in CompatGHC.vcat+ [ beginningDoc+ , CompatGHC.blankLine+ ]++formatAliasUniquenssViolation :: NEL.NonEmpty CodeStructure.Import -> CompatGHC.SDoc+formatAliasUniquenssViolation imps =+ let rebuildFromImport imp =+ rebuildImportStatementFromScheme (CodeStructure.importedModule imp)+ . CodeStructure.buildScheme+ . CompatGHC.unLoc+ $ CodeStructure.importDecl imp+ beginningDoc =+ CompatGHC.hang+ ( CompatGHC.sep+ [ CompatGHC.hsep+ [ CompatGHC.text "Multiple imports share an alias that must be unique."+ ]+ , CompatGHC.cat+ [ CompatGHC.text "The imports are"+ , CompatGHC.colon+ ]+ ]+ )+ 4+ (CompatGHC.vcat . fmap rebuildFromImport $ NEL.toList imps)+ in CompatGHC.vcat+ [ beginningDoc+ , CompatGHC.blankLine+ ]++{- | Rebuild the part of an import statement we subject to rules, namely everything up to explicit+ items imported or hiding+-}+rebuildImportStatementFromScheme :: CompatGHC.ModuleName -> CodeStructure.Scheme -> CompatGHC.SDoc+rebuildImportStatementFromScheme modName schema =+ CompatGHC.hsep+ [ CompatGHC.dot+ , CompatGHC.hsep+ [ CompatGHC.text "import"+ , if CodeStructure.safeToBool (CodeStructure.safe schema)+ then+ CompatGHC.text "safe"+ else+ -- Purposely do not mention the safe keyword when not forced, as+ -- this makes the output needlessly complex and we don't need to+ -- mention something requiring an extension if users didn't ask for+ -- it explicitly.+ CompatGHC.empty+ , case CodeStructure.qualification schema of+ CompatGHC.QualifiedPre -> CompatGHC.text "qualified"+ CompatGHC.QualifiedPost -> CompatGHC.empty+ CompatGHC.NotQualified -> CompatGHC.empty+ , case CodeStructure.packageQualification schema of+ -- The order here is very important, as package qualified imports must come after safe+ -- and prepositive qualified.+ CodeStructure.WithoutPackageQualifier ->+ CompatGHC.empty+ CodeStructure.WithPackageQualifier str ->+ CompatGHC.doubleQuotes $ CompatGHC.text (T.unpack str)+ , CompatGHC.ppr modName+ , case CodeStructure.qualification schema of+ CompatGHC.QualifiedPre -> CompatGHC.empty+ CompatGHC.QualifiedPost -> CompatGHC.text "qualified"+ CompatGHC.NotQualified -> CompatGHC.empty+ , case CodeStructure.alias schema of+ CodeStructure.WithoutAlias ->+ CompatGHC.empty+ CodeStructure.WithAlias name ->+ CompatGHC.hsep+ [ CompatGHC.text "as"+ , CompatGHC.ppr name+ ]+ ]+ ]
+ src/Henforcer/CodeStructure.hs view
@@ -0,0 +1,15 @@+{-# OPTIONS_GHC -Wno-missing-import-lists #-}++{- |+Module : Henforcer.CodeStructure+Description : All of the internal representations of various forms of source code, such as import statements are defined in submodules of this tree and are re-exported here.+Copyright : (c) Flipstone Technology Partners, 2023-2026+License : MIT+Maintainer : maintainers@flipstone.com+-}+module Henforcer.CodeStructure+ ( module Export+ ) where++import Henforcer.CodeStructure.Import as Export+import Henforcer.CodeStructure.ModuleTree as Export
+ src/Henforcer/CodeStructure/Import.hs view
@@ -0,0 +1,16 @@+{-# OPTIONS_GHC -Wno-missing-import-lists #-}++{- |+Module : Henforcer.Import+Description :+Copyright : (c) Flipstone Technology Partners, 2023-2026+License : MIT+Maintainer : maintainers@flipstone.com+-}+module Henforcer.CodeStructure.Import+ ( module Export+ ) where++import Henforcer.CodeStructure.Import.AllowedAliasUniqueness as Export+import Henforcer.CodeStructure.Import.Import as Export+import Henforcer.CodeStructure.Import.Scheme as Export
+ src/Henforcer/CodeStructure/Import/AllowedAliasUniqueness.hs view
@@ -0,0 +1,73 @@+{- |+Module : Henforcer.CodeStructure.Import.AllowedAliasUniqueness+Description :+Copyright : (c) Flipstone Technology Partners, 2023-2026+License : MIT+Maintainer : maintainers@flipstone.com+-}+module Henforcer.CodeStructure.Import.AllowedAliasUniqueness+ ( AllowedAliasUniqueness (..)+ , allowedAliasUniquenessCodec+ , AliasUniquenessExceptions+ ( AliasUniquenessExceptions+ , aliasUniquenessExceptionsAliases+ , aliasUniquenessExceptionsNote+ )+ , AliasUniquenessRequired (AliasUniquenessRequired)+ ) where++import Control.Applicative ((<|>))+import qualified Data.Set as Set+import qualified Toml++import qualified CompatGHC+import qualified Henforcer.Rules.UserNote as UserNote+import qualified TomlHelper++data AllowedAliasUniqueness+ = AllAliasesUniqueExcept !AliasUniquenessExceptions+ | AliasesToBeUnique !AliasUniquenessRequired+ deriving (Eq, Show)++data AliasUniquenessExceptions = AliasUniquenessExceptions+ { aliasUniquenessExceptionsAliases :: !(Set.Set CompatGHC.ModuleName)+ , aliasUniquenessExceptionsNote :: !UserNote.UserNote+ }+ deriving (Eq, Show)++data AliasUniquenessRequired = AliasUniquenessRequired+ { aliasUniquenessRequiredAliases :: !(Set.Set CompatGHC.ModuleName)+ , aliasUniquenessRequiredNote :: !UserNote.UserNote+ }+ deriving (Eq, Show)++matchExcept :: AllowedAliasUniqueness -> Maybe AliasUniquenessExceptions+matchExcept (AllAliasesUniqueExcept excepts) = Just excepts+matchExcept (AliasesToBeUnique _) = Nothing++matchUnique :: AllowedAliasUniqueness -> Maybe AliasUniquenessRequired+matchUnique (AllAliasesUniqueExcept _) = Nothing+matchUnique (AliasesToBeUnique uniqs) = Just uniqs++aliasUniquenessExceptionsCodec :: Toml.TomlCodec AliasUniquenessExceptions+aliasUniquenessExceptionsCodec =+ AliasUniquenessExceptions+ <$> TomlHelper.addField+ "allAliasesUniqueExcept"+ aliasUniquenessExceptionsAliases+ (Toml.dimap Set.toList Set.fromList . CompatGHC.moduleNameListCodec)+ <*> UserNote.userNoteField aliasUniquenessExceptionsNote++aliasUniquenessRequiredCodec :: Toml.TomlCodec AliasUniquenessRequired+aliasUniquenessRequiredCodec =+ AliasUniquenessRequired+ <$> TomlHelper.addField+ "uniqueAliases"+ aliasUniquenessRequiredAliases+ (Toml.dimap Set.toList Set.fromList . CompatGHC.moduleNameListCodec)+ <*> UserNote.userNoteField aliasUniquenessRequiredNote++allowedAliasUniquenessCodec :: Toml.TomlCodec AllowedAliasUniqueness+allowedAliasUniquenessCodec =+ Toml.dimatch matchExcept AllAliasesUniqueExcept aliasUniquenessExceptionsCodec+ <|> Toml.dimatch matchUnique AliasesToBeUnique aliasUniquenessRequiredCodec
+ src/Henforcer/CodeStructure/Import/Import.hs view
@@ -0,0 +1,65 @@+{- |+Module : Henforcer.CodeStructure.Import.Import+Description :+Copyright : (c) Flipstone Technology Partners, 2023-2026+License : MIT+Maintainer : maintainers@flipstone.com+-}+module Henforcer.CodeStructure.Import.Import+ ( Import (srcModule, importDecl)+ , srcLocation+ , importedModule+ , getImports+ , importIsOpenWithNoHidingOrAlias+ ) where++import qualified CompatGHC+import Henforcer.CodeStructure.Import.Scheme (Alias (WithoutAlias), Scheme (Scheme), buildScheme)++{- | `Import` is a subset of a CompatGHC.HsModule to be a slightly more ergonomic interface.++@since 1.0.0.0+-}+data Import = Import+ { srcModule :: !CompatGHC.ModuleName -- Do not support unnamed modules just yet!+ , importDecl :: !(CompatGHC.LImportDecl CompatGHC.GhcRn)+ }++{- | Get a 'SrcSpan' to track a location for an import++@since 1.0.0.0+-}+srcLocation :: Import -> CompatGHC.SrcSpan+srcLocation = CompatGHC.locA . CompatGHC.getLoc . importDecl++{- | Get the name of the module being imported++@since 1.0.0.0+-}+importedModule :: Import -> CompatGHC.ModuleName+importedModule = CompatGHC.unLoc . CompatGHC.ideclName . CompatGHC.unLoc . importDecl++{- | Get all of the 'Import's from a 'TcGblEnv'.++@since 1.0.0.0+-}+getImports :: CompatGHC.TcGblEnv -> [Import]+getImports tcGblEnv =+ let+ name = CompatGHC.moduleName $ CompatGHC.tcg_mod tcGblEnv+ in+ fmap (Import name) $ CompatGHC.tcg_rn_imports tcGblEnv++{- | Determine if the import is open, with no qualification, no alias, and no hiding++@since 1.0.0.0+-}+importIsOpenWithNoHidingOrAlias :: Import -> Bool+importIsOpenWithNoHidingOrAlias imp =+ let rawImportDecl = CompatGHC.unLoc $ importDecl imp+ in case buildScheme rawImportDecl of+ Scheme CompatGHC.NotQualified WithoutAlias _ _ ->+ case CompatGHC.ideclImportList rawImportDecl of+ Nothing -> True+ Just _ -> False+ _hasSomeAlias -> False
+ src/Henforcer/CodeStructure/Import/Scheme.hs view
@@ -0,0 +1,17 @@+{-# OPTIONS_GHC -Wno-missing-import-lists #-}++{- |+Module : Henforcer.CodeStructure.Import.Scheme+Description : Models the representation of import statements and how a user wants some modules to be imported.+Copyright : (c) Flipstone Technology Partners, 2023-2026+License : MIT+Maintainer : maintainers@flipstone.com+-}+module Henforcer.CodeStructure.Import.Scheme+ ( module Export+ ) where++import Henforcer.CodeStructure.Import.Scheme.Alias as Export+import Henforcer.CodeStructure.Import.Scheme.PackageQualifier as Export+import Henforcer.CodeStructure.Import.Scheme.Safe as Export+import Henforcer.CodeStructure.Import.Scheme.Scheme as Export
+ src/Henforcer/CodeStructure/Import/Scheme/Alias.hs view
@@ -0,0 +1,49 @@+{- |+Module : Henforcer.CodeStructure.Import.Scheme.Alias+Description : Models the representation of an alias portion of an import statement.+Copyright : (c) Flipstone Technology Partners, 2023-2026+License : MIT+Maintainer : maintainers@flipstone.com+-}+module Henforcer.CodeStructure.Import.Scheme.Alias+ ( Alias (..)+ , aliasCodecWithDefault+ , determineAlias+ ) where++import qualified Toml++import qualified CompatGHC++{- | Directly represent if an import has an alias or not.++@since 1.0.0.0+-}+data Alias+ = WithAlias !CompatGHC.ModuleName+ | WithoutAlias+ deriving (Eq, Show)++maybeFromAlias :: Alias -> Maybe CompatGHC.ModuleName+maybeFromAlias WithoutAlias = Nothing+maybeFromAlias (WithAlias x) = Just x++aliasCodec :: Toml.Key -> Toml.TomlCodec Alias+aliasCodec =+ Toml.dimatch maybeFromAlias WithAlias . CompatGHC.moduleNameCodec++defaultWithoutAlias :: Maybe Alias -> Alias+defaultWithoutAlias Nothing = WithoutAlias+defaultWithoutAlias (Just x) = x++aliasCodecWithDefault :: Toml.Key -> Toml.TomlCodec Alias+aliasCodecWithDefault =+ Toml.dimap pure defaultWithoutAlias . Toml.dioptional . aliasCodec++{- | Compute the alias from an import++@since 1.0.0.0+-}+determineAlias :: CompatGHC.ImportDecl CompatGHC.GhcRn -> Alias+determineAlias =+ maybe WithoutAlias (WithAlias . CompatGHC.unLoc) . CompatGHC.ideclAs
+ src/Henforcer/CodeStructure/Import/Scheme/PackageQualifier.hs view
@@ -0,0 +1,55 @@+{- |+Module : Henforcer.CodeStructure.Import.Scheme.PackageQualified+Description : Models the representation of a package qualifier portion of an import statement.+Copyright : (c) Flipstone Technology Partners, 2023-2026+License : MIT+Maintainer : maintainers@flipstone.com+-}+module Henforcer.CodeStructure.Import.Scheme.PackageQualifier+ ( PackageQualifier (..)+ , packageQualifierCodec+ , determinePackageQualifier+ , keepPackageNameOnly+ ) where++import qualified Data.Text as T+import qualified Toml++import qualified CompatGHC++{- | Directly represent if an import has a package qualifier or not.++@since 1.0.0.0+-}+data PackageQualifier+ = WithPackageQualifier !T.Text+ | WithoutPackageQualifier+ deriving (Eq, Show)++maybeFromPackageQualifier :: PackageQualifier -> Maybe T.Text+maybeFromPackageQualifier WithoutPackageQualifier = Nothing+maybeFromPackageQualifier (WithPackageQualifier x) = Just x++packageQualifierCodec :: Toml.Key -> Toml.TomlCodec PackageQualifier+{-# INLINEABLE packageQualifierCodec #-}+packageQualifierCodec =+ Toml.dimatch maybeFromPackageQualifier WithPackageQualifier . Toml.text++{- | Compute the packageQualifier from an import++@since 1.0.0.0+-}+determinePackageQualifier :: CompatGHC.ImportDecl CompatGHC.GhcRn -> PackageQualifier+determinePackageQualifier idecl =+ case CompatGHC.ideclPkgQual idecl of+ CompatGHC.NoPkgQual -> WithoutPackageQualifier+ CompatGHC.ThisPkg u -> WithPackageQualifier (T.pack $ CompatGHC.unitIdString u)+ CompatGHC.OtherPkg u -> WithPackageQualifier (T.pack $ CompatGHC.unitIdString u)++keepPackageNameOnly :: T.Text -> Maybe T.Text+keepPackageNameOnly =+ headMay . T.split (== '-')++headMay :: [a] -> Maybe a+headMay [] = Nothing+headMay (x : _) = Just x
+ src/Henforcer/CodeStructure/Import/Scheme/Safe.hs view
@@ -0,0 +1,56 @@+{- |+Module : Henforcer.CodeStructure.Import.Scheme.Safe+Description : Models the representation of the safe portion of an import statement.+Copyright : (c) Flipstone Technology Partners, 2023-2026+License : MIT+Maintainer : maintainers@flipstone.com+-}+module Henforcer.CodeStructure.Import.Scheme.Safe+ ( Safe+ , safeToBool+ , safeCodec+ , determineSafe+ , withoutSafe+ ) where++import qualified Toml+import qualified TomlHelper++import qualified CompatGHC++{- | Directly represent if an import is 'safe' or not.++@since 1.0.0.0+-}+newtype Safe = Safe Bool+ deriving (Eq, Show)++{- | Toml codec based on bool for 'Safe' with a default of not including 'Safe'++@since 1.0.0.0+-}+safeCodec :: Toml.Key -> Toml.TomlCodec Safe+safeCodec =+ TomlHelper.setDefault (Safe False) (Toml.diwrap . Toml.bool)++{- | Conversion to 'Bool' is used for conditional logic, notably checking failure.++@since 1.0.0.0+-}+safeToBool :: Safe -> Bool+safeToBool (Safe b) = b++{- | Compute the safety from an import++@since 1.0.0.0+-}+determineSafe :: CompatGHC.ImportDecl CompatGHC.GhcRn -> Safe+determineSafe =+ Safe . CompatGHC.ideclSafe++{- | Safe unset, used for tests++@since 1.0.0.0+-}+withoutSafe :: Safe+withoutSafe = Safe False
+ src/Henforcer/CodeStructure/Import/Scheme/Scheme.hs view
@@ -0,0 +1,205 @@+{- |+Module : Henforcer.CodeStructure.Import.Scheme.Scheme+Description : Models the style of import including qualification, alias, and safety.+Copyright : (c) Flipstone Technology Partners, 2023-2026+License : MIT+Maintainer : maintainers@flipstone.com+-}+module Henforcer.CodeStructure.Import.Scheme.Scheme+ ( Scheme (..)+ , SchemeWithNote (..)+ , AllowedSchemes+ , buildScheme+ , allowedSchemesCodec+ , keepOnlyPackageNameInQualifier+ ) where++import qualified Control.Monad as M+import qualified Data.Map.Strict as Map+import qualified Data.String as String+import qualified Data.Text as T+import qualified Toml++import qualified CompatGHC+import Henforcer.CodeStructure.Import.Scheme.Alias+ ( Alias+ , aliasCodecWithDefault+ , determineAlias+ )+import Henforcer.CodeStructure.Import.Scheme.PackageQualifier+ ( PackageQualifier (WithPackageQualifier, WithoutPackageQualifier)+ , determinePackageQualifier+ , keepPackageNameOnly+ , packageQualifierCodec+ )+import Henforcer.CodeStructure.Import.Scheme.Safe (Safe, determineSafe, safeCodec)+import qualified Henforcer.Rules as Rules+import qualified TomlHelper++{- | Representation of the structure of on an import, covering the qualification, any aliasing, and+the safety.++@since 1.0.0.0+-}+data Scheme = Scheme+ { qualification :: !CompatGHC.ImportDeclQualifiedStyle+ , alias :: !Alias+ , safe :: !Safe+ , packageQualification :: !PackageQualifier+ }+ deriving (Eq, Show)++{- | The 'Scheme' along with the 'UserNote' that was requested to be printed in the case of failures.++@since 1.0.0.0+-}+data SchemeWithNote = SchemeWithNote+ { schemeNote :: !Rules.UserNote+ , underlyingScheme :: !Scheme+ }+ deriving (Eq, Show)++{- | The 'SchemeWithNote's that should be allowed for each 'CompatGHC.ModuleName'.++@since 1.0.0.0+-}+type AllowedSchemes =+ Map.Map CompatGHC.ModuleName [SchemeWithNote]++{- | Conversion for 'AllowedSchemes' that performs conversion through 'SchemeToml'.++@since 1.0.0.0+-}+allowedSchemesCodec :: Toml.Key -> Toml.TomlCodec AllowedSchemes+allowedSchemesCodec =+ Toml.dimap ((fmap . fmap) schemeToToml) (fmap tomlsToSchemes)+ . Toml.map+ (CompatGHC.moduleNameCodec (String.fromString "module"))+ (Toml.list schemeTomlCodec (String.fromString "importScheme"))++{- | Compute the 'Scheme' from an import++@since 1.0.0.0+-}+buildScheme :: CompatGHC.ImportDecl CompatGHC.GhcRn -> Scheme+buildScheme imp =+ Scheme+ { qualification = CompatGHC.ideclQualified imp+ , alias = determineAlias imp+ , safe = determineSafe imp+ , packageQualification = determinePackageQualifier imp+ }++{- | The Toml verion of an import scheme. This is an intermediate type to facilitate configuration in+ a more ergonomic manner.++@since 1.0.0.0+-}+data SchemeToml = SchemeToml+ { tomlAlias :: !Alias+ , tomlSafe :: !Safe+ , tomlPackageQualification :: !PackageQualifier+ , tomlQualification :: !QualificationToml+ , tomlSchemeNote :: !Rules.UserNote+ }++schemeTomlCodec :: Toml.TomlCodec SchemeToml+schemeTomlCodec =+ SchemeToml+ <$> TomlHelper.addField "alias" tomlAlias aliasCodecWithDefault+ <*> TomlHelper.addField "safe" tomlSafe safeCodec+ <*> TomlHelper.addField+ "packageQualified"+ tomlPackageQualification+ (TomlHelper.setDefault WithoutPackageQualifier packageQualifierCodec)+ <*> TomlHelper.addField "qualified" tomlQualification (Toml.table qualificationTomlCodec)+ <*> Rules.userNoteField tomlSchemeNote++schemeToToml :: SchemeWithNote -> SchemeToml+schemeToToml withNote =+ let+ s = underlyingScheme withNote+ in+ SchemeToml+ { tomlAlias = alias s+ , tomlSafe = safe s+ , tomlPackageQualification = packageQualification s+ , tomlQualification = qualificationStyleToToml $ qualification s+ , tomlSchemeNote = schemeNote withNote+ }++tomlsToSchemes :: [SchemeToml] -> [SchemeWithNote]+tomlsToSchemes =+ M.join . fmap explodeSchemeToml++explodeSchemeToml :: SchemeToml -> [SchemeWithNote]+explodeSchemeToml st =+ explodeQualificationToml+ (tomlSchemeNote st)+ (tomlAlias st)+ (tomlSafe st)+ (tomlPackageQualification st)+ (tomlQualification st)++{- | Filters out version and seperators so we can look only at the package portion for comparsion.++@since 1.0.0.0+-}+keepOnlyPackageNameInQualifier :: Scheme -> Scheme+keepOnlyPackageNameInQualifier s =+ let+ mbGetQualifierText :: PackageQualifier -> Maybe T.Text+ mbGetQualifierText (WithPackageQualifier t) = Just t+ mbGetQualifierText WithoutPackageQualifier = Nothing++ newQualifier =+ maybe WithoutPackageQualifier WithPackageQualifier+ . M.join+ . fmap keepPackageNameOnly+ . mbGetQualifierText+ $ packageQualification s+ in+ s{packageQualification = newQualifier}++{- | Representation of the choices for qualification as it is presented in the toml config.++@since 1.0.0.0+-}+data QualificationToml = QualificationToml+ { qualifiedPre :: !Bool+ , qualifiedPost :: !Bool+ , unqualified :: !Bool+ }++qualificationTomlCodec :: Toml.TomlCodec QualificationToml+qualificationTomlCodec =+ QualificationToml+ <$> TomlHelper.addField "qualifiedPre" qualifiedPre (TomlHelper.setDefault False Toml.bool)+ <*> TomlHelper.addField "qualifiedPost" qualifiedPost (TomlHelper.setDefault False Toml.bool)+ <*> TomlHelper.addField "unqualified" unqualified (TomlHelper.setDefault False Toml.bool)++qualificationTomlToQualifications :: QualificationToml -> [CompatGHC.ImportDeclQualifiedStyle]+qualificationTomlToQualifications i =+ case i of+ (QualificationToml False False False) -> []+ (QualificationToml True False False) -> [CompatGHC.QualifiedPre]+ (QualificationToml False True False) -> [CompatGHC.QualifiedPost]+ (QualificationToml False False True) -> [CompatGHC.NotQualified]+ (QualificationToml True True False) -> [CompatGHC.QualifiedPre, CompatGHC.QualifiedPost]+ (QualificationToml True False True) -> [CompatGHC.QualifiedPre, CompatGHC.NotQualified]+ (QualificationToml False True True) -> [CompatGHC.QualifiedPost, CompatGHC.NotQualified]+ (QualificationToml True True True) -> [CompatGHC.QualifiedPre, CompatGHC.QualifiedPost, CompatGHC.NotQualified]++qualificationStyleToToml :: CompatGHC.ImportDeclQualifiedStyle -> QualificationToml+qualificationStyleToToml CompatGHC.QualifiedPre = QualificationToml True False False+qualificationStyleToToml CompatGHC.QualifiedPost = QualificationToml False True False+qualificationStyleToToml CompatGHC.NotQualified = QualificationToml False False True++explodeQualificationToml ::+ Rules.UserNote -> Alias -> Safe -> PackageQualifier -> QualificationToml -> [SchemeWithNote]+explodeQualificationToml note a s p =+ let+ mkScheme q =+ SchemeWithNote note (Scheme q a s p)+ in+ fmap mkScheme . qualificationTomlToQualifications
+ src/Henforcer/CodeStructure/ModuleTree.hs view
@@ -0,0 +1,131 @@+{- |+Module : Henforcer.CodeStructure.ModuleTree+Description : Definition of 'ModuleTree', parsing, and related functionality.+Copyright : (c) Flipstone Technology Partners, 2023-2026+License : MIT+Maintainer : maintainers@flipstone.com+-}+module Henforcer.CodeStructure.ModuleTree+ ( ModuleTree+ , parse+ , isSuperTreeOf+ , treeContainsModule+ , treeStrictlyContainsModule+ , moduleTreeCodec+ , moduleTreeListCodec+ ) where++import qualified Data.List.NonEmpty as NEL+import qualified Data.Text as T+import qualified Toml++import qualified CompatGHC++{- | Conceptually a "module tree" refers to a root module (e.g. `Data.Text`) and all the modules are+prefixed by it (e.g. `Data.Text.Encoding` and `Data.Text.Lazy`). A 'ModuleTree' is a+representation of a 'CompatGHC.ModuleName'+@since 1.0.0.0+-}+data ModuleTree+ = ModuleTree !String !(Maybe ModuleTree)+ deriving (Eq, Show)++-- | @since 1.0.0.0+instance CompatGHC.Outputable ModuleTree where+ ppr =+ CompatGHC.text . format++{- | Invert 'parse', using "." as the separator between parts of the 'ModuleTree'.++@since 1.0.0.0+-}+format :: ModuleTree -> String+format (ModuleTree name maybeRest) =+ let+ joinName rest =+ name <> ('.' : format rest)+ in+ maybe name joinName maybeRest++{- | Parse a 'String' into a 'ModuleTree', the input will not be validated.++@since 1.0.0.0+-}+parse :: String -> ModuleTree+parse str =+ let+ addPart newPart subModuleTree =+ Just (ModuleTree newPart subModuleTree)++ (x NEL.:| xs) = moduleNameParts str+ in+ ModuleTree x $ foldr addPart Nothing xs++{- | Is a 'ModuleTree' contained within another 'ModuleTree'.++@since 1.0.0.0+-}+isSuperTreeOf :: ModuleTree -> ModuleTree -> Bool+isSuperTreeOf (ModuleTree parent mbParentRest) (ModuleTree child mbChildRest) =+ (parent == child)+ && case (mbParentRest, mbChildRest) of+ (Nothing, Just _) ->+ True+ (Just _, Nothing) ->+ False+ (Nothing, Nothing) ->+ True+ (Just parentRest, Just childRest) ->+ isSuperTreeOf parentRest childRest++{- | Is a 'CompatGHC.ModuleName' contained within a 'ModuleTree'.++@since 1.0.0.0+-}+treeContainsModule :: ModuleTree -> CompatGHC.ModuleName -> Bool+treeContainsModule moduleTree =+ isSuperTreeOf moduleTree . moduleTreeOfModule++{- | Is a 'CompatGHC.ModuleName' contained within a 'ModuleTree' without being exactly the+'ModuleTree'.++@since 1.0.0.0+-}+treeStrictlyContainsModule :: ModuleTree -> CompatGHC.ModuleName -> Bool+treeStrictlyContainsModule moduleTree modName =+ let moduleTreeForName = moduleTreeOfModule modName+ in (moduleTree /= moduleTreeForName)+ && isSuperTreeOf moduleTree moduleTreeForName++{- | Parse a 'CompatGHC.ModuleName' into a 'ModuleTree'.++@since 1.0.0.0+-}+moduleTreeOfModule :: CompatGHC.ModuleName -> ModuleTree+moduleTreeOfModule =+ parse . CompatGHC.moduleNameString++moduleNameParts :: String -> NEL.NonEmpty String+moduleNameParts modName =+ case break (== '.') modName of+ (firstPart, '.' : rest) ->+ NEL.cons firstPart $ moduleNameParts rest+ (onlyPart, _) ->+ pure onlyPart++{- | A codec for a single 'ModuleTree'++@since 1.0.0.0+-}+moduleTreeCodec :: Toml.Key -> Toml.TomlCodec ModuleTree+moduleTreeCodec =+ Toml.dimap format parse . Toml.string++{- | A codec for a list of 'ModuleTree' that is required and if missing will throw as opposed to+being an empty list.++@since 1.0.0.0+-}+moduleTreeListCodec :: Toml.Key -> Toml.TomlCodec [ModuleTree]+moduleTreeListCodec =+ Toml.arrayOf (Toml._TextBy (T.pack . format) (pure . parse . T.unpack))
+ src/Henforcer/Config.hs view
@@ -0,0 +1,19 @@+{-# OPTIONS_GHC -Wno-missing-import-lists #-}++{- |+Module : Henforcer.Config+Description : The configuration definition and functionality for working with it.+Copyright : (c) Flipstone Technology Partners, 2023-2026+License : MIT+Maintainer : maintainers@flipstone.com+-}+module Henforcer.Config+ ( module Export+ ) where++import Henforcer.Config.Config as Export+import Henforcer.Config.ForAnyModule as Export+import Henforcer.Config.ForPatternModule as Export+import Henforcer.Config.ForSpecifiedModule as Export+import Henforcer.Config.IgnoreRules as Export+import Henforcer.Config.TreeDependencies as Export
+ src/Henforcer/Config/Config.hs view
@@ -0,0 +1,45 @@+{- |+Module : Henforcer.Config.Config+Description : Haskell representation of the toml configuration file that is used to define the checks to be enforced. As well as related functionality.+Copyright : (c) Flipstone Technology Partners, 2023-2026+License : MIT+Maintainer : maintainers@flipstone.com+-}+module Henforcer.Config.Config+ ( Config (..)+ , loadConfig+ ) where++import qualified Toml++import qualified TomlHelper++import Henforcer.Config.ForAnyModule (ForAnyModule, emptyForAnyModule, forAnyModuleCodec)+import Henforcer.Config.ForPatternModule (ForPatternModules, forPatternModulesCodecField)+import Henforcer.Config.ForSpecifiedModule (ForSpecifiedModules, forSpecifiedModulesCodecField)++data Config = Config+ { forAnyModule :: !ForAnyModule+ , forPatternModules :: !ForPatternModules+ , forSpecifiedModules :: !ForSpecifiedModules+ }++configCodec :: Toml.TomlCodec Config+configCodec =+ Config+ <$> TomlHelper.addField+ "forAnyModule"+ forAnyModule+ (TomlHelper.setDefault emptyForAnyModule (Toml.table forAnyModuleCodec))+ <*> TomlHelper.addField+ "forPatternModules"+ forPatternModules+ forPatternModulesCodecField+ <*> TomlHelper.addField+ "forSpecifiedModules"+ forSpecifiedModules+ forSpecifiedModulesCodecField++loadConfig :: FilePath -> IO Config+loadConfig =+ Toml.decodeFile configCodec
+ src/Henforcer/Config/ForAnyModule.hs view
@@ -0,0 +1,109 @@+{- |+Module : Henforcer.Config+Description : Functionaly around specifying rules that apply to any given module.+Copyright : (c) Flipstone Technology Partners, 2023-2026+License : MIT+Maintainer : maintainers@flipstone.com+-}+module Henforcer.Config.ForAnyModule+ ( ForAnyModule (..)+ , forAnyModuleCodec+ , emptyForAnyModule+ ) where++import qualified Toml++import qualified Henforcer.CodeStructure as CodeStructure+import Henforcer.Config.TreeDependencies (TreeDependency, treeDependencyCodec)+import qualified Henforcer.Rules as Rules+import qualified TomlHelper++data ForAnyModule = ForAnyModule+ { anyModuleTreeDependencies :: ![TreeDependency]+ , anyModuleEncapsulatedTrees :: ![CodeStructure.ModuleTree]+ , anyModuleAllowedQualifications :: !CodeStructure.AllowedSchemes+ , anyModuleAllowedOpenUnaliasedImports :: !Rules.MaximumAllowed+ , anyModuleAllowedAliasUniqueness :: !(Maybe CodeStructure.AllowedAliasUniqueness)+ , anyModuleMaximumUndocumentedExports :: !Rules.MaximumAllowed+ , anyModuleMinimumDocumentedExports :: !Rules.MinimumAllowed+ , anyModuleMaximumExportsWithoutSince :: !Rules.MaximumAllowed+ , anyModuleMinimumExportsWithSince :: !Rules.MinimumAllowed+ , anyModuleModuleHeaderCopyrightMustExistNonEmpty :: !Rules.MustExistNonEmpty+ , anyModuleModuleHeaderDescriptionMustExistNonEmpty :: !Rules.MustExistNonEmpty+ , anyModuleModuleHeaderLicenseMustExistNonEmpty :: !Rules.MustExistNonEmpty+ , anyModuleModuleHeaderMaintainerMustExistNonEmpty :: !Rules.MustExistNonEmpty+ }++forAnyModuleCodec :: Toml.TomlCodec ForAnyModule+forAnyModuleCodec =+ ForAnyModule+ <$> TomlHelper.addField+ "treeDependencies"+ anyModuleTreeDependencies+ (Toml.list treeDependencyCodec)+ <*> TomlHelper.addField+ "encapsulatedTrees"+ anyModuleEncapsulatedTrees+ (TomlHelper.setDefault [] CodeStructure.moduleTreeListCodec)+ <*> TomlHelper.addField+ "allowedQualifications"+ anyModuleAllowedQualifications+ CodeStructure.allowedSchemesCodec+ <*> TomlHelper.addField+ "allowedOpenUnaliasedImports"+ anyModuleAllowedOpenUnaliasedImports+ Rules.maximumAllowedCodec+ <*> TomlHelper.addField+ "allowedAliasUniqueness"+ anyModuleAllowedAliasUniqueness+ (Toml.dioptional . Toml.table CodeStructure.allowedAliasUniquenessCodec)+ <*> TomlHelper.addField+ "maximumExportsPlusHeaderUndocumented"+ anyModuleMaximumUndocumentedExports+ Rules.maximumAllowedCodec+ <*> TomlHelper.addField+ "minimumExportsPlusHeaderDocumented"+ anyModuleMinimumDocumentedExports+ Rules.minimumAllowedCodec+ <*> TomlHelper.addField+ "maximumExportsWithoutSince"+ anyModuleMaximumExportsWithoutSince+ Rules.maximumAllowedCodec+ <*> TomlHelper.addField+ "minimumExportsWithSince"+ anyModuleMinimumExportsWithSince+ Rules.minimumAllowedCodec+ <*> TomlHelper.addField+ "moduleHeaderCopyrightMustExistNonEmpty"+ anyModuleModuleHeaderCopyrightMustExistNonEmpty+ Rules.mustExistNonEmptyCodec+ <*> TomlHelper.addField+ "moduleHeaderDescriptionMustExistNonEmpty"+ anyModuleModuleHeaderDescriptionMustExistNonEmpty+ Rules.mustExistNonEmptyCodec+ <*> TomlHelper.addField+ "moduleHeaderLicenseMustExistNonEmpty"+ anyModuleModuleHeaderLicenseMustExistNonEmpty+ Rules.mustExistNonEmptyCodec+ <*> TomlHelper.addField+ "moduleHeaderMaintainerMustExistNonEmpty"+ anyModuleModuleHeaderMaintainerMustExistNonEmpty+ Rules.mustExistNonEmptyCodec++emptyForAnyModule :: ForAnyModule+emptyForAnyModule =+ ForAnyModule+ { anyModuleTreeDependencies = mempty+ , anyModuleEncapsulatedTrees = mempty+ , anyModuleAllowedQualifications = mempty+ , anyModuleAllowedOpenUnaliasedImports = Rules.NotEnforced+ , anyModuleAllowedAliasUniqueness = Nothing+ , anyModuleMaximumUndocumentedExports = Rules.NotEnforced+ , anyModuleMinimumDocumentedExports = Rules.NotEnforced+ , anyModuleMaximumExportsWithoutSince = Rules.NotEnforced+ , anyModuleMinimumExportsWithSince = Rules.NotEnforced+ , anyModuleModuleHeaderCopyrightMustExistNonEmpty = Rules.NotEnforced+ , anyModuleModuleHeaderDescriptionMustExistNonEmpty = Rules.NotEnforced+ , anyModuleModuleHeaderLicenseMustExistNonEmpty = Rules.NotEnforced+ , anyModuleModuleHeaderMaintainerMustExistNonEmpty = Rules.NotEnforced+ }
+ src/Henforcer/Config/ForPatternModule.hs view
@@ -0,0 +1,90 @@+{- |+Module : Henforcer.Config.ForPatternModule+Description : Functionality for specifying rules scoped to a particular module.+Copyright : (c) Flipstone Technology Partners, 2024-2026+License : MIT+Maintainer : maintainers@flipstone.com+-}+module Henforcer.Config.ForPatternModule+ ( moduleMatchesPattern+ , ForPatternModule+ , ForPatternModules+ , forPatternModulesCodecField+ , unionPatternAndSpecifiedModule+ ) where++import qualified Control.Applicative as A+import qualified Data.List as List+import qualified Data.Maybe as Maybe+import qualified Data.String as String+import qualified System.FilePattern as FP+import qualified Toml++import qualified Henforcer.Config.ForSpecifiedModule as FSM++moduleMatchesPattern :: String -> ForPatternModules -> Maybe ForPatternModule+moduleMatchesPattern moduleName =+ List.find (wildcardMatch moduleName . fst)++wildcardMatch :: String -> FP.FilePattern -> Bool+wildcardMatch str pat =+ Maybe.isJust $+ FP.match+ (replaceSeparator pat)+ (replaceSeparator str)++replaceSeparator :: String -> String+replaceSeparator [] = []+replaceSeparator str@(x : xs) =+ case List.stripPrefix "." str of+ Just stripped -> "/" <> replaceSeparator stripped+ Nothing -> x : replaceSeparator xs++type ForPatternModule = (FP.FilePattern, FSM.ForSpecifiedModule)+type ForPatternModules = [ForPatternModule]++forPatternModulesCodecField :: Toml.Key -> Toml.TomlCodec ForPatternModules+forPatternModulesCodecField =+ Toml.list (Toml.pair (Toml.string $ String.fromString "pattern") FSM.forSpecifiedModuleCodec)++unionPatternAndSpecifiedModule ::+ FSM.ForSpecifiedModule -> FSM.ForSpecifiedModule -> FSM.ForSpecifiedModule+unionPatternAndSpecifiedModule fpm fsm =+ FSM.ForSpecifiedModule+ { FSM.specifiedModuleAllowedQualifications =+ FSM.specifiedModuleAllowedQualifications fsm+ A.<|> FSM.specifiedModuleAllowedQualifications fpm+ , FSM.specifiedModuleAllowedOpenUnaliasedImports =+ FSM.specifiedModuleAllowedOpenUnaliasedImports fsm+ A.<|> FSM.specifiedModuleAllowedOpenUnaliasedImports fpm+ , FSM.specifiedModuleAllowedAliasUniqueness =+ FSM.specifiedModuleAllowedAliasUniqueness fsm+ A.<|> FSM.specifiedModuleAllowedAliasUniqueness fpm+ , FSM.specifiedModuleMaximumUndocumentedExports =+ FSM.specifiedModuleMaximumUndocumentedExports fsm+ A.<|> FSM.specifiedModuleMaximumUndocumentedExports fpm+ , FSM.specifiedModuleMinimumDocumentedExports =+ FSM.specifiedModuleMinimumDocumentedExports fsm+ A.<|> FSM.specifiedModuleMinimumDocumentedExports fpm+ , FSM.specifiedModuleMaximumExportsWithoutSince =+ FSM.specifiedModuleMaximumExportsWithoutSince fsm+ A.<|> FSM.specifiedModuleMaximumExportsWithoutSince fpm+ , FSM.specifiedModuleMinimumExportsWithSince =+ FSM.specifiedModuleMinimumExportsWithSince fsm+ A.<|> FSM.specifiedModuleMinimumExportsWithSince fpm+ , FSM.specifiedModuleModuleHeaderCopyrightMustExistNonEmpty =+ FSM.specifiedModuleModuleHeaderCopyrightMustExistNonEmpty fsm+ A.<|> FSM.specifiedModuleModuleHeaderCopyrightMustExistNonEmpty fpm+ , FSM.specifiedModuleModuleHeaderDescriptionMustExistNonEmpty =+ FSM.specifiedModuleModuleHeaderDescriptionMustExistNonEmpty fsm+ A.<|> FSM.specifiedModuleModuleHeaderDescriptionMustExistNonEmpty fpm+ , FSM.specifiedModuleModuleHeaderLicenseMustExistNonEmpty =+ FSM.specifiedModuleModuleHeaderLicenseMustExistNonEmpty fsm+ A.<|> FSM.specifiedModuleModuleHeaderLicenseMustExistNonEmpty fpm+ , FSM.specifiedModuleModuleHeaderMaintainerMustExistNonEmpty =+ FSM.specifiedModuleModuleHeaderMaintainerMustExistNonEmpty fsm+ A.<|> FSM.specifiedModuleModuleHeaderMaintainerMustExistNonEmpty fpm+ , FSM.specifiedModuleRulesToIgnore =+ FSM.specifiedModuleRulesToIgnore fsm+ A.<|> FSM.specifiedModuleRulesToIgnore fpm+ }
+ src/Henforcer/Config/ForSpecifiedModule.hs view
@@ -0,0 +1,114 @@+{- |+Module : Henforcer.Config.ForSpecifiedModule+Description : Functionality for specifying rules scoped to a particular module.+Copyright : (c) Flipstone Technology Partners, 2024-2026+License : MIT+Maintainer : maintainers@flipstone.com+-}+module Henforcer.Config.ForSpecifiedModule+ ( ForSpecifiedModule (..)+ , emptyForSpecifiedModule+ , forSpecifiedModuleCodec+ , forSpecifiedModulesCodecField+ , ForSpecifiedModules+ ) where++import qualified Data.String as String+import qualified Toml++import qualified CompatGHC+import qualified Henforcer.CodeStructure as CodeStructure+import qualified Henforcer.Config.IgnoreRules as IgnoreRules+import qualified Henforcer.Rules as Rules+import qualified TomlHelper++data ForSpecifiedModule = ForSpecifiedModule+ { specifiedModuleAllowedQualifications :: !(Maybe CodeStructure.AllowedSchemes)+ , specifiedModuleAllowedOpenUnaliasedImports :: !(Maybe Rules.MaximumAllowed)+ , specifiedModuleAllowedAliasUniqueness :: !(Maybe CodeStructure.AllowedAliasUniqueness)+ , specifiedModuleMaximumUndocumentedExports :: !(Maybe Rules.MaximumAllowed)+ , specifiedModuleMinimumDocumentedExports :: !(Maybe Rules.MinimumAllowed)+ , specifiedModuleMaximumExportsWithoutSince :: !(Maybe Rules.MaximumAllowed)+ , specifiedModuleMinimumExportsWithSince :: !(Maybe Rules.MinimumAllowed)+ , specifiedModuleModuleHeaderCopyrightMustExistNonEmpty :: !(Maybe Rules.MustExistNonEmpty)+ , specifiedModuleModuleHeaderDescriptionMustExistNonEmpty :: !(Maybe Rules.MustExistNonEmpty)+ , specifiedModuleModuleHeaderLicenseMustExistNonEmpty :: !(Maybe Rules.MustExistNonEmpty)+ , specifiedModuleModuleHeaderMaintainerMustExistNonEmpty :: !(Maybe Rules.MustExistNonEmpty)+ , specifiedModuleRulesToIgnore :: !(Maybe IgnoreRules.RulesToIgnore)+ }++emptyForSpecifiedModule :: ForSpecifiedModule+emptyForSpecifiedModule =+ ForSpecifiedModule+ { specifiedModuleAllowedQualifications = Nothing+ , specifiedModuleAllowedOpenUnaliasedImports = Nothing+ , specifiedModuleAllowedAliasUniqueness = Nothing+ , specifiedModuleMaximumUndocumentedExports = Nothing+ , specifiedModuleMinimumDocumentedExports = Nothing+ , specifiedModuleMaximumExportsWithoutSince = Nothing+ , specifiedModuleMinimumExportsWithSince = Nothing+ , specifiedModuleModuleHeaderCopyrightMustExistNonEmpty = Nothing+ , specifiedModuleModuleHeaderDescriptionMustExistNonEmpty = Nothing+ , specifiedModuleModuleHeaderLicenseMustExistNonEmpty = Nothing+ , specifiedModuleModuleHeaderMaintainerMustExistNonEmpty = Nothing+ , specifiedModuleRulesToIgnore = Nothing+ }++forSpecifiedModuleCodec :: Toml.TomlCodec ForSpecifiedModule+forSpecifiedModuleCodec =+ ForSpecifiedModule+ <$> TomlHelper.addField+ "allowedQualifications"+ specifiedModuleAllowedQualifications+ (Toml.dioptional . CodeStructure.allowedSchemesCodec)+ <*> TomlHelper.addField+ "allowedOpenUnaliasedImports"+ specifiedModuleAllowedOpenUnaliasedImports+ (Toml.dioptional . Rules.maximumAllowedCodec)+ <*> TomlHelper.addField+ "allowedAliasUniqueness"+ specifiedModuleAllowedAliasUniqueness+ (Toml.dioptional . Toml.table CodeStructure.allowedAliasUniquenessCodec)+ <*> TomlHelper.addField+ "maximumExportsPlusHeaderUndocumented"+ specifiedModuleMaximumUndocumentedExports+ (Toml.dioptional . Rules.maximumAllowedCodec)+ <*> TomlHelper.addField+ "minimumExportsPlusHeaderDocumented"+ specifiedModuleMinimumDocumentedExports+ (Toml.dioptional . Rules.minimumAllowedCodec)+ <*> TomlHelper.addField+ "maximumExportsWithoutSince"+ specifiedModuleMaximumExportsWithoutSince+ (Toml.dioptional . Rules.maximumAllowedCodec)+ <*> TomlHelper.addField+ "minimumExportsWithSince"+ specifiedModuleMinimumExportsWithSince+ (Toml.dioptional . Rules.minimumAllowedCodec)+ <*> TomlHelper.addField+ "moduleHeaderCopyrightMustExistNonEmpty"+ specifiedModuleModuleHeaderCopyrightMustExistNonEmpty+ (Toml.dioptional . Rules.mustExistNonEmptyCodec)+ <*> TomlHelper.addField+ "moduleHeaderDescriptionMustExistNonEmpty"+ specifiedModuleModuleHeaderDescriptionMustExistNonEmpty+ (Toml.dioptional . Rules.mustExistNonEmptyCodec)+ <*> TomlHelper.addField+ "moduleHeaderLicenseMustExistNonEmpty"+ specifiedModuleModuleHeaderLicenseMustExistNonEmpty+ (Toml.dioptional . Rules.mustExistNonEmptyCodec)+ <*> TomlHelper.addField+ "moduleHeaderMaintainerMustExistNonEmpty"+ specifiedModuleModuleHeaderMaintainerMustExistNonEmpty+ (Toml.dioptional . Rules.mustExistNonEmptyCodec)+ <*> TomlHelper.addField+ "rulesToIgnore"+ specifiedModuleRulesToIgnore+ (Toml.dioptional . Toml.table IgnoreRules.rulestoIgnoreCodec)++type ForSpecifiedModules = [(CompatGHC.ModuleName, ForSpecifiedModule)]++forSpecifiedModulesCodecField :: Toml.Key -> Toml.TomlCodec ForSpecifiedModules+forSpecifiedModulesCodecField =+ Toml.list+ (Toml.pair (CompatGHC.moduleNameCodec $ String.fromString "module") forSpecifiedModuleCodec)
+ src/Henforcer/Config/IgnoreRules.hs view
@@ -0,0 +1,127 @@+{- |+Module : Henforcer.Config.IgnoreRules+Description : Functionality for specifying that some rules in TOML configuration file should be ignored.+Copyright : (c) Flipstone Technology Partners, 2023-2026+License : MIT+Maintainer : maintainers@flipstone.com+-}+module Henforcer.Config.IgnoreRules+ ( IgnoreRules (..)+ , RulesToIgnore (..)+ , rulestoIgnoreCodec+ , isRuleIgnored+ ) where++import Control.Applicative ((<|>))+import qualified Data.String as String+import qualified Toml++import qualified TomlHelper++{- | Do we want to ignore all rules or some that are listed. This serves as a way to make writing+the configuration for users easier, as they can quickly turn off all checks for a module.+-}+data RulesToIgnore+ = All !Bool+ | SpecificRulesToIgnore !IgnoreRules++matchAll :: RulesToIgnore -> Maybe Bool+matchAll (All b) = Just b+matchAll _ = Nothing++matchSpecificRulesToIgnore :: RulesToIgnore -> Maybe IgnoreRules+matchSpecificRulesToIgnore (All _) = Nothing+matchSpecificRulesToIgnore (SpecificRulesToIgnore rules) = Just rules++rulestoIgnoreCodec :: Toml.TomlCodec RulesToIgnore+rulestoIgnoreCodec =+ Toml.dimatch matchAll All (Toml.bool (String.fromString "all"))+ <|> Toml.dimatch matchSpecificRulesToIgnore SpecificRulesToIgnore ignoreRulesCodec++{- | Specify which rules to ignore, note that this is intended to be used when specifying modules in+some fashion. To ignore rules at the top level would be to simply not enable them.+-}+data IgnoreRules = IgnoreRules+ { ignoreRulesTreeDependencies :: !Bool+ , ignoreRulesEncapsulatedTrees :: !Bool+ , ignoreRulesAllowedQualifications :: !Bool+ , ignoreRulesAllowedOpenUnaliasedImports :: !Bool+ , ignoreRulesAllowedAliasUniqueness :: !Bool+ , ignoreRulesMaximumUndocumentedExports :: !Bool+ , ignoreRulesMinimumDocumentedExports :: !Bool+ , ignoreRulesMaximumExportsWithoutSince :: !Bool+ , ignoreRulesMinimumExportsWithSince :: !Bool+ , ignoreRulesModuleHeaderCopyrightMustExistNonEmpty :: !Bool+ , ignoreRulesModuleHeaderDescriptionMustExistNonEmpty :: !Bool+ , ignoreRulesModuleHeaderLicenseMustExistNonEmpty :: !Bool+ , ignoreRulesModuleHeaderMaintainerMustExistNonEmpty :: !Bool+ }++ignoreRulesCodec :: Toml.TomlCodec IgnoreRules+ignoreRulesCodec =+ IgnoreRules+ <$> TomlHelper.addField+ "treeDependencies"+ ignoreRulesTreeDependencies+ boolDefaultFalseField+ <*> TomlHelper.addField+ "encapsulatedTrees"+ ignoreRulesEncapsulatedTrees+ boolDefaultFalseField+ <*> TomlHelper.addField+ "allowedQualifications"+ ignoreRulesAllowedQualifications+ boolDefaultFalseField+ <*> TomlHelper.addField+ "allowedOpenUnaliasedImports"+ ignoreRulesAllowedOpenUnaliasedImports+ boolDefaultFalseField+ <*> TomlHelper.addField+ "allowedAliasUniqueness"+ ignoreRulesAllowedAliasUniqueness+ boolDefaultFalseField+ <*> TomlHelper.addField+ "maximumExportsPlusHeaderUndocumented"+ ignoreRulesMaximumUndocumentedExports+ boolDefaultFalseField+ <*> TomlHelper.addField+ "minimumExportsPlusHeaderDocumented"+ ignoreRulesMinimumDocumentedExports+ boolDefaultFalseField+ <*> TomlHelper.addField+ "maximumExportsWithoutSince"+ ignoreRulesMaximumExportsWithoutSince+ boolDefaultFalseField+ <*> TomlHelper.addField+ "minimumExportsWithSince"+ ignoreRulesMinimumExportsWithSince+ boolDefaultFalseField+ <*> TomlHelper.addField+ "moduleHeaderCopyrightMustExistNonEmpty"+ ignoreRulesModuleHeaderCopyrightMustExistNonEmpty+ boolDefaultFalseField+ <*> TomlHelper.addField+ "moduleHeaderDescriptionMustExistNonEmpty"+ ignoreRulesModuleHeaderDescriptionMustExistNonEmpty+ boolDefaultFalseField+ <*> TomlHelper.addField+ "moduleHeaderLicenseMustExistNonEmpty"+ ignoreRulesModuleHeaderLicenseMustExistNonEmpty+ boolDefaultFalseField+ <*> TomlHelper.addField+ "moduleHeaderMaintainerMustExistNonEmpty"+ ignoreRulesModuleHeaderMaintainerMustExistNonEmpty+ boolDefaultFalseField++-- | Default a 'Bool' field+boolDefaultFalseField :: Toml.Key -> Toml.TomlCodec Bool+boolDefaultFalseField =+ TomlHelper.setDefault False Toml.bool++isRuleIgnored ::+ (IgnoreRules -> Bool)+ -> RulesToIgnore+ -> Bool+isRuleIgnored _ (All b) = b+isRuleIgnored accessor (SpecificRulesToIgnore ignoreRules) =+ accessor ignoreRules
+ src/Henforcer/Config/TreeDependencies.hs view
@@ -0,0 +1,36 @@+{- |+Module : Henforcer.Config.TreeDependencies+Description : Functionality for specifying module trees that depend on other module trees.+Copyright : (c) Flipstone Technology Partners, 2024-2026+License : MIT+Maintainer : maintainers@flipstone.com+-}+module Henforcer.Config.TreeDependencies+ ( TreeDependency (..)+ , treeDependencyCodec+ ) where++import qualified Toml++import qualified Henforcer.CodeStructure as CodeStructure+import qualified Henforcer.Rules as Rules+import qualified TomlHelper++{- | Type to allow us to specify when a subtree depends on other subtrees. Particularly this allows+for a relatively compact expression in the user facing TOML. This expression is why the module is+placed under 'Henforcer.Config' and not elsewhere such as 'Henforcer.Rules'.++@since 1.0.0.0+-}+data TreeDependency = TreeDependency+ { moduleTree :: !CodeStructure.ModuleTree+ , treeDependencies :: ![CodeStructure.ModuleTree]+ , treeDependencyNote :: !Rules.UserNote+ }++treeDependencyCodec :: Toml.TomlCodec TreeDependency+treeDependencyCodec =+ TreeDependency+ <$> TomlHelper.addField "moduleTree" moduleTree CodeStructure.moduleTreeCodec+ <*> TomlHelper.addField "dependencies" treeDependencies CodeStructure.moduleTreeListCodec+ <*> Rules.userNoteField treeDependencyNote
+ src/Henforcer/Options.hs view
@@ -0,0 +1,37 @@+{- |+Module : Henforcer.Options+Description :+Copyright : (c) Flipstone Technology Partners, 2023-2026+License : MIT+Maintainer : maintainers@flipstone.com+-}+module Henforcer.Options+ ( Options (..)+ , parseGivenOptions+ ) where++import qualified Options.Applicative as Opt++newtype Options = Options+ { configPath :: FilePath+ }++parseGivenOptions :: [String] -> IO Options+parseGivenOptions =+ Opt.handleParseResult . Opt.execParserPure Opt.defaultPrefs optionsInfo++optionsInfo :: Opt.ParserInfo Options+optionsInfo =+ Opt.info+ optionsParser+ mempty++optionsParser :: Opt.Parser Options+optionsParser =+ Options+ <$> Opt.strOption+ ( Opt.long "config"+ <> Opt.short 'c'+ <> Opt.value "./henforcer.toml"+ <> Opt.showDefault+ )
+ src/Henforcer/Rules.hs view
@@ -0,0 +1,18 @@+{-# OPTIONS_GHC -Wno-missing-import-lists #-}++{- |+Module : Henforcer.Rules+Description :+Copyright : (c) Flipstone Technology Partners, 2024-2026+License : MIT+Maintainer : maintainers@flipstone.com+-}+module Henforcer.Rules+ ( module Export+ ) where++import Henforcer.Rules.ConditionallyEnforced as Export+import Henforcer.Rules.Maximum as Export+import Henforcer.Rules.Minimum as Export+import Henforcer.Rules.MustExistNonEmpty as Export+import Henforcer.Rules.UserNote as Export
+ src/Henforcer/Rules/ConditionallyEnforced.hs view
@@ -0,0 +1,35 @@+{- |+Module : Henforcer.Rules.ConditionallyEnforced+Description :+Copyright : (c) Flipstone Technology Partners, 2024-2026+License : MIT+Maintainer : maintainers@flipstone.com+-}+module Henforcer.Rules.ConditionallyEnforced+ ( ConditionallyEnforced (..)+ , conditionallyEnforcedCodec+ ) where++import qualified Toml++-- | A more expressive 'Maybe'+data ConditionallyEnforced a+ = Enforced !a+ | NotEnforced+ deriving (Eq, Show)++conditionallyEnforcedCodec ::+ (Toml.Key -> Toml.TomlCodec a) -> Toml.Key -> Toml.TomlCodec (ConditionallyEnforced a)+{-# INLINEABLE conditionallyEnforcedCodec #-}+conditionallyEnforcedCodec underlyingCodec =+ Toml.dimap maybeFromConditionallyEnforced conditionallyEnforcedFromMaybe+ . Toml.dioptional+ . underlyingCodec++conditionallyEnforcedFromMaybe :: Maybe a -> ConditionallyEnforced a+conditionallyEnforcedFromMaybe Nothing = NotEnforced+conditionallyEnforcedFromMaybe (Just x) = Enforced x++maybeFromConditionallyEnforced :: ConditionallyEnforced a -> Maybe a+maybeFromConditionallyEnforced NotEnforced = Nothing+maybeFromConditionallyEnforced (Enforced x) = Just x
+ src/Henforcer/Rules/Maximum.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++{- |+Module : Henforcer.Rules.Maximum+Description : Generic rule for allowing enforcement of an upper bound+Copyright : (c) Flipstone Technology Partners, 2023-2026+License : MIT+Maintainer : maintainers@flipstone.com+-}+module Henforcer.Rules.Maximum+ ( checkMaximum+ , MaximumAllowed+ , maximumAllowedCodec+ , MaximumNat+ ) where++import qualified Numeric.Natural as Nat+import qualified Toml++import qualified CompatGHC+import Henforcer.Rules.ConditionallyEnforced+ ( ConditionallyEnforced (Enforced, NotEnforced)+ , conditionallyEnforcedCodec+ )++checkMaximum ::+ (Applicative m, Monoid (m b)) =>+ MaximumAllowed+ -> a+ -> (a -> MaximumNat)+ -> (a -> MaximumNat -> b)+ -> m b+checkMaximum maximumAllowed a getNat handleFailure =+ case maximumAllowed of+ NotEnforced ->+ mempty+ Enforced maxNat ->+ let moduleNat = getNat a+ in if moduleNat > maxNat+ then pure $ handleFailure a maxNat+ else mempty++type MaximumAllowed = ConditionallyEnforced MaximumNat++maximumAllowedCodec :: Toml.Key -> Toml.TomlCodec MaximumAllowed+{-# INLINEABLE maximumAllowedCodec #-}+maximumAllowedCodec = conditionallyEnforcedCodec maximumNatCodec++-- | A wrapper around 'Nat.Natural' for clarity+newtype MaximumNat = MaximumNat Nat.Natural+ deriving (Num, Eq, Ord, Show)++instance CompatGHC.Outputable MaximumNat where+ ppr = CompatGHC.text . show . maximumNatToNatural++maximumNatToNatural :: MaximumNat -> Nat.Natural+maximumNatToNatural (MaximumNat nat) = nat++maximumNatCodec :: Toml.Key -> Toml.TomlCodec MaximumNat+maximumNatCodec =+ Toml.diwrap . Toml.natural
+ src/Henforcer/Rules/Minimum.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++{- |+Module : Henforcer.Rules.Minimum+Description : Generic rule for allowing enforcement of a lower bound+Copyright : (c) Flipstone Technology Partners, 2023-2026+License : MIT+Maintainer : maintainers@flipstone.com+-}+module Henforcer.Rules.Minimum+ ( checkMinimum+ , MinimumAllowed+ , minimumAllowedCodec+ , MinimumNat+ ) where++import qualified Numeric.Natural as Nat+import qualified Toml++import qualified CompatGHC+import Henforcer.Rules.ConditionallyEnforced+ ( ConditionallyEnforced (Enforced, NotEnforced)+ , conditionallyEnforcedCodec+ )++{- | If a 'MinimumAllowed' is to be enforced, then for a given value, get++@since 1.0.0.0+-}+checkMinimum ::+ (Applicative m, Monoid (m b)) =>+ MinimumAllowed+ -> a+ -> (a -> MinimumNat)+ -> (a -> MinimumNat -> b)+ -> m b+checkMinimum minimumAllowed a getNat handleFailure =+ case minimumAllowed of+ NotEnforced ->+ mempty+ Enforced minNat ->+ let moduleNat = getNat a+ in if moduleNat < minNat+ then pure $ handleFailure a minNat+ else mempty++type MinimumAllowed = ConditionallyEnforced MinimumNat++minimumAllowedCodec :: Toml.Key -> Toml.TomlCodec MinimumAllowed+{-# INLINEABLE minimumAllowedCodec #-}+minimumAllowedCodec = conditionallyEnforcedCodec minimumNatCodec++{- | A wrapper around 'Nat.Natural' for clarity++@since 1.0.0.0+-}+newtype MinimumNat = MinimumNat Nat.Natural+ deriving (Num, Eq, Ord, Show)++{- |++@since 1.0.0.0+-}+instance CompatGHC.Outputable MinimumNat where+ ppr (MinimumNat nat) = CompatGHC.text $ show nat++minimumNatCodec :: Toml.Key -> Toml.TomlCodec MinimumNat+minimumNatCodec =+ Toml.diwrap . Toml.natural
+ src/Henforcer/Rules/MustExistNonEmpty.hs view
@@ -0,0 +1,47 @@+{- |+Module : Henforcer.Rules.MustExistNonEmpty+Description :+Copyright : (c) Flipstone Technology Partners, 2023-2026+License : MIT+Maintainer : maintainers@flipstone.com+-}+module Henforcer.Rules.MustExistNonEmpty+ ( MustExistNonEmpty+ , mustExistNonEmptyCodec+ , checkExistsAndNonEmptyString+ ) where++import qualified Toml++import Henforcer.Rules.ConditionallyEnforced+ ( ConditionallyEnforced (Enforced, NotEnforced)+ , conditionallyEnforcedCodec+ )++type MustExistNonEmpty = ConditionallyEnforced Bool++mustExistNonEmptyCodec :: Toml.Key -> Toml.TomlCodec MustExistNonEmpty+{-# INLINEABLE mustExistNonEmptyCodec #-}+mustExistNonEmptyCodec = conditionallyEnforcedCodec Toml.bool++checkExistsAndNonEmptyString ::+ (Applicative m, Monoid (m b)) =>+ MustExistNonEmpty+ -> a+ -> (a -> Maybe String)+ -> (a -> b)+ -> m b+checkExistsAndNonEmptyString mustExistNonEmpty a getStr handleFailure =+ case mustExistNonEmpty of+ NotEnforced ->+ mempty+ Enforced False ->+ mempty+ Enforced True ->+ case getStr a of+ Nothing ->+ pure $ handleFailure a+ Just "" ->+ pure $ handleFailure a+ Just _ ->+ mempty
+ src/Henforcer/Rules/UserNote.hs view
@@ -0,0 +1,64 @@+{- |+Module : Henforcer.Rules.UserNote+Description : Generic field for user defined notes+Copyright : (c) Flipstone Technology Partners, 2024-2026+License : MIT+Maintainer : maintainers@flipstone.com+-}+module Henforcer.Rules.UserNote+ ( UserNote+ , userNoteField+ , FailureWithUserNote (userNotes, underlyingFailure)+ , failureWithUserNotes+ , failureWithUserNote+ , failureWithNoNote+ , noUserNote+ ) where++import qualified Data.Maybe as Maybe+import qualified Toml++import qualified CompatGHC+import qualified TomlHelper++newtype UserNote = UserNote (Maybe String)+ deriving (Eq, Show)++userNoteMbStr :: UserNote -> Maybe String+userNoteMbStr (UserNote mbStr) = mbStr++userNoteCodec :: Toml.Key -> Toml.TomlCodec UserNote+userNoteCodec =+ Toml.diwrap . Toml.dioptional . Toml.string++userNoteField :: (object -> UserNote) -> Toml.Codec object UserNote+{-# INLINEABLE userNoteField #-}+userNoteField accessor =+ TomlHelper.addField "note" accessor userNoteCodec++noUserNote :: UserNote+noUserNote = UserNote Nothing++data FailureWithUserNote a = FailureWithUserNote+ { userNotes :: ![UserNote]+ , underlyingFailure :: !a+ }++instance (CompatGHC.Outputable a) => CompatGHC.Outputable (FailureWithUserNote a) where+ ppr withUserNote =+ let+ underlyingDoc = CompatGHC.ppr (underlyingFailure withUserNote)+ in+ case Maybe.mapMaybe userNoteMbStr $ userNotes withUserNote of+ [] -> underlyingDoc+ noteStrs ->+ CompatGHC.vcat $ pure underlyingDoc <> fmap (CompatGHC.text . ("Note: " <>)) noteStrs++failureWithUserNotes :: [UserNote] -> a -> FailureWithUserNote a+failureWithUserNotes = FailureWithUserNote++failureWithUserNote :: UserNote -> a -> FailureWithUserNote a+failureWithUserNote note = failureWithUserNotes (pure note)++failureWithNoNote :: a -> FailureWithUserNote a+failureWithNoNote = failureWithUserNote noUserNote
+ src/TomlHelper.hs view
@@ -0,0 +1,35 @@+{- |+Module : TomlHelper+Description : Helpers to make dealing with toml easier.+Copyright : (c) Flipstone Technology Partners, 2024-2026+License : MIT+Maintainer : maintainers@flipstone.com+-}+module TomlHelper+ ( addField+ , setDefault+ ) where++import qualified Data.String as String+import qualified Toml++{- | A convience wrapper for 'Toml..='++@since 1.0.0.0+-}+addField ::+ String -> (object -> field) -> (Toml.Key -> Toml.TomlCodec field) -> Toml.Codec object field+addField fieldName fieldAccessor codec =+ codec (String.fromString fieldName) Toml..= fieldAccessor++{- | Set a default for what would otherwise be an optional.++@since 1.0.0.0+-}+setDefault :: a -> (Toml.Key -> Toml.TomlCodec a) -> Toml.Key -> Toml.TomlCodec a+setDefault defaultVal codec =+ let+ handleDefault Nothing = defaultVal+ handleDefault (Just x) = x+ in+ Toml.dimap pure handleDefault . Toml.dioptional . codec
+ test/Main.hs view
@@ -0,0 +1,15 @@+module Main+ ( main+ ) where++import qualified Test.Tasty as Tasty++import qualified Test.Config as TestConfig++import qualified Henforcer.Config as Config++main :: IO ()+main = do+ conf <- Config.loadConfig "test/test-config.toml"++ Tasty.defaultMain $ TestConfig.configTests conf
+ test/Test/Config.hs view
@@ -0,0 +1,19 @@+module Test.Config+ ( configTests+ ) where++import qualified Test.Tasty as Tasty++import qualified Henforcer.Config as Config+import Test.Config.Documentation+ ( checkDocumentation+ )+import Test.Config.Import (checkImport)++configTests :: Config.Config -> Tasty.TestTree+configTests conf =+ Tasty.testGroup+ "Configuration parsing tests"+ [ checkDocumentation conf+ , checkImport conf+ ]
+ test/Test/Config/Documentation.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE OverloadedStrings #-}++module Test.Config.Documentation+ ( checkDocumentation+ ) where++import qualified Hedgehog as HH+import qualified Test.Tasty as Tasty+import qualified Test.Tasty.Hedgehog as TastyHH++import qualified CompatGHC+import qualified Henforcer.Checks as Checks+import qualified Henforcer.Config as Config+import qualified Henforcer.Rules as Rules++singleProperty :: Tasty.TestName -> HH.PropertyT IO () -> Tasty.TestTree+singleProperty name =+ TastyHH.testProperty name . HH.withTests 1 . HH.property++checkDocumentation :: Config.Config -> Tasty.TestTree+checkDocumentation conf =+ Tasty.testGroup+ "Checking configuration parsing of documentation rules"+ [ checkAnyModule conf+ , checkPatternModule conf+ , checkPatternModulePicksFirst conf+ , checkSpecifiedModule conf+ , checkPatternModuleIgnores conf+ ]++checkAnyModule :: Config.Config -> Tasty.TestTree+checkAnyModule conf =+ singleProperty "Does folding correctly for any module section" $+ documentationAnyModuleRules+ HH.=== Checks.determineDocumentationChecks conf (CompatGHC.mkModuleName "AnyModule")++checkPatternModule :: Config.Config -> Tasty.TestTree+checkPatternModule conf =+ singleProperty "Picks pattern module section when module matches" $+ documentationPatternModuleRules+ HH.=== Checks.determineDocumentationChecks conf (CompatGHC.mkModuleName "Pattern.Module")++checkPatternModulePicksFirst :: Config.Config -> Tasty.TestTree+checkPatternModulePicksFirst conf =+ singleProperty "Overlapping patterns pick the first match" $+ documentationPatternModuleRules+ HH.=== Checks.determineDocumentationChecks conf (CompatGHC.mkModuleName "Pattern2.Module")++checkSpecifiedModule :: Config.Config -> Tasty.TestTree+checkSpecifiedModule conf =+ singleProperty "Specified module is picked even if the pattern is matched" $+ documentationSpecifiedModuleRules+ HH.=== Checks.determineDocumentationChecks+ conf+ (CompatGHC.mkModuleName "PatternMatchedButSpecifiedWins.Module")++checkPatternModuleIgnores :: Config.Config -> Tasty.TestTree+checkPatternModuleIgnores conf =+ singleProperty "Pattern module can ignore rules " $+ documentationPatternWithIgnoresModuleRules+ HH.=== Checks.determineDocumentationChecks conf (CompatGHC.mkModuleName "WithIgnoresPattern.Module")++documentationAnyModuleRules :: Checks.DocumentationChecks+documentationAnyModuleRules =+ Checks.DocumentationChecks+ { Checks.maximumUndocumentedExports = Rules.Enforced 3+ , Checks.minimumDocumentedExports = Rules.Enforced 3+ , Checks.maximumExportsWithoutSince = Rules.Enforced 3+ , Checks.minimumExportsWithSince = Rules.Enforced 3+ , Checks.moduleHeaderCopyrightMustExistNonEmpty = Rules.Enforced True+ , Checks.moduleHeaderDescriptionMustExistNonEmpty = Rules.Enforced True+ , Checks.moduleHeaderLicenseMustExistNonEmpty = Rules.Enforced True+ , Checks.moduleHeaderMaintainerMustExistNonEmpty = Rules.Enforced True+ }++documentationPatternModuleRules :: Checks.DocumentationChecks+documentationPatternModuleRules =+ Checks.DocumentationChecks+ { Checks.maximumUndocumentedExports = Rules.Enforced 2+ , Checks.minimumDocumentedExports = Rules.Enforced 2+ , Checks.maximumExportsWithoutSince = Rules.Enforced 2+ , Checks.minimumExportsWithSince = Rules.Enforced 2+ , Checks.moduleHeaderCopyrightMustExistNonEmpty = Rules.Enforced False+ , Checks.moduleHeaderDescriptionMustExistNonEmpty = Rules.Enforced False+ , Checks.moduleHeaderLicenseMustExistNonEmpty = Rules.Enforced False+ , Checks.moduleHeaderMaintainerMustExistNonEmpty = Rules.Enforced False+ }++documentationPatternWithIgnoresModuleRules :: Checks.DocumentationChecks+documentationPatternWithIgnoresModuleRules =+ Checks.DocumentationChecks+ { Checks.maximumUndocumentedExports = Rules.NotEnforced+ , Checks.minimumDocumentedExports = Rules.NotEnforced+ , Checks.maximumExportsWithoutSince = Rules.NotEnforced+ , Checks.minimumExportsWithSince = Rules.NotEnforced+ , Checks.moduleHeaderCopyrightMustExistNonEmpty = Rules.NotEnforced+ , Checks.moduleHeaderDescriptionMustExistNonEmpty = Rules.NotEnforced+ , Checks.moduleHeaderLicenseMustExistNonEmpty = Rules.NotEnforced+ , Checks.moduleHeaderMaintainerMustExistNonEmpty = Rules.NotEnforced+ }++documentationSpecifiedModuleRules :: Checks.DocumentationChecks+documentationSpecifiedModuleRules =+ Checks.DocumentationChecks+ { Checks.maximumUndocumentedExports = Rules.Enforced 20+ , Checks.minimumDocumentedExports = Rules.Enforced 20+ , Checks.maximumExportsWithoutSince = Rules.Enforced 20+ , Checks.minimumExportsWithSince = Rules.Enforced 20+ , Checks.moduleHeaderCopyrightMustExistNonEmpty = Rules.Enforced True+ , Checks.moduleHeaderDescriptionMustExistNonEmpty = Rules.Enforced True+ , Checks.moduleHeaderLicenseMustExistNonEmpty = Rules.Enforced True+ , Checks.moduleHeaderMaintainerMustExistNonEmpty = Rules.Enforced True+ }
+ test/Test/Config/Import.hs view
@@ -0,0 +1,216 @@+{-# LANGUAGE OverloadedStrings #-}++module Test.Config.Import+ ( checkImport+ ) where++import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import qualified Hedgehog as HH+import qualified Test.Tasty as Tasty+import qualified Test.Tasty.Hedgehog as TastyHH++import qualified CompatGHC+import qualified Henforcer.Checks as Checks+import qualified Henforcer.CodeStructure as CodeStructure+import qualified Henforcer.Config as Config+import qualified Henforcer.Rules as Rules++singleProperty :: Tasty.TestName -> HH.PropertyT IO () -> Tasty.TestTree+singleProperty name =+ TastyHH.testProperty name . HH.withTests 1 . HH.property++checkImport :: Config.Config -> Tasty.TestTree+checkImport conf =+ Tasty.testGroup+ "Checking configuration parsing of import rules"+ [ checkAnyModule conf+ , checkPatternModule conf+ , checkPatternModulePicksFirst conf+ , checkSpecifiedModule conf+ , checkPatternModuleIgnores conf+ ]++checkAnyModule :: Config.Config -> Tasty.TestTree+checkAnyModule conf =+ singleProperty "Does folding correctly for any module section" $+ importAnyModuleRules+ HH.=== Checks.determineChecks conf (CompatGHC.mkModuleName "AnyModule")++checkPatternModule :: Config.Config -> Tasty.TestTree+checkPatternModule conf =+ singleProperty "Picks pattern module section when module matches" $+ importPatternModuleRules+ HH.=== Checks.determineChecks conf (CompatGHC.mkModuleName "Pattern.Module")++checkPatternModulePicksFirst :: Config.Config -> Tasty.TestTree+checkPatternModulePicksFirst conf =+ singleProperty "Overlapping patterns pick the first match" $+ importPatternModuleRules+ HH.=== Checks.determineChecks conf (CompatGHC.mkModuleName "Pattern2.Module")++checkSpecifiedModule :: Config.Config -> Tasty.TestTree+checkSpecifiedModule conf =+ singleProperty "Specified module is picked even if the pattern is matched" $+ importSpecifiedModuleRules+ HH.=== Checks.determineChecks+ conf+ (CompatGHC.mkModuleName "PatternMatchedButSpecifiedWins.Module")++checkPatternModuleIgnores :: Config.Config -> Tasty.TestTree+checkPatternModuleIgnores conf =+ singleProperty "Pattern module can ignore rules " $+ importPatternWithIgnoresModuleRules+ HH.=== Checks.determineChecks conf (CompatGHC.mkModuleName "WithIgnoresPattern.Module")++importAnyModuleRules :: Checks.ImportChecks+importAnyModuleRules =+ Checks.ImportChecks+ { Checks.importChecksTreeDependencies =+ Just . pure $+ Checks.CheckedDependency+ (CodeStructure.parse "Control.Monad")+ Rules.noUserNote+ (CodeStructure.parse "PetStore")+ , Checks.importChecksEncapsulatedTrees =+ Just (pure (CodeStructure.parse "Service.ThirdPartyPetsSite"))+ , Checks.importChecksAllowedQualifications =+ Map.fromList+ [+ ( CompatGHC.mkModuleName "UnliftIO"+ ,+ [ CodeStructure.SchemeWithNote+ { CodeStructure.schemeNote = Rules.noUserNote+ , CodeStructure.underlyingScheme =+ CodeStructure.Scheme+ { CodeStructure.qualification = CompatGHC.QualifiedPre+ , CodeStructure.alias = CodeStructure.WithAlias (CompatGHC.mkModuleName "Foo")+ , CodeStructure.safe = CodeStructure.withoutSafe+ , CodeStructure.packageQualification = CodeStructure.WithPackageQualifier "unliftio"+ }+ }+ , CodeStructure.SchemeWithNote+ { CodeStructure.schemeNote = Rules.noUserNote+ , CodeStructure.underlyingScheme =+ CodeStructure.Scheme+ { CodeStructure.qualification = CompatGHC.QualifiedPost+ , CodeStructure.alias = CodeStructure.WithAlias (CompatGHC.mkModuleName "Foo")+ , CodeStructure.safe = CodeStructure.withoutSafe+ , CodeStructure.packageQualification = CodeStructure.WithPackageQualifier "unliftio"+ }+ }+ ]+ )+ ]+ , Checks.importChecksAllowedOpenUnaliasedImports = Rules.Enforced 3+ , Checks.importChecksAllowedAliasUniqueness =+ Just . CodeStructure.AllAliasesUniqueExcept $+ CodeStructure.AliasUniquenessExceptions+ (Set.singleton $ CompatGHC.mkModuleName "Export")+ Rules.noUserNote+ }++importPatternModuleRules :: Checks.ImportChecks+importPatternModuleRules =+ Checks.ImportChecks+ { Checks.importChecksTreeDependencies =+ Just . pure $+ Checks.CheckedDependency+ (CodeStructure.parse "Control.Monad")+ Rules.noUserNote+ (CodeStructure.parse "PetStore")+ , Checks.importChecksEncapsulatedTrees =+ Just (pure (CodeStructure.parse "Service.ThirdPartyPetsSite"))+ , Checks.importChecksAllowedQualifications =+ Map.fromList+ [+ ( CompatGHC.mkModuleName "UnliftIO"+ ,+ [ CodeStructure.SchemeWithNote+ { CodeStructure.schemeNote = Rules.noUserNote+ , CodeStructure.underlyingScheme =+ CodeStructure.Scheme+ { CodeStructure.qualification = CompatGHC.QualifiedPre+ , CodeStructure.alias = CodeStructure.WithAlias (CompatGHC.mkModuleName "Foo")+ , CodeStructure.safe = CodeStructure.withoutSafe+ , CodeStructure.packageQualification = CodeStructure.WithPackageQualifier "unliftio"+ }+ }+ , CodeStructure.SchemeWithNote+ { CodeStructure.schemeNote = Rules.noUserNote+ , CodeStructure.underlyingScheme =+ CodeStructure.Scheme+ { CodeStructure.qualification = CompatGHC.QualifiedPost+ , CodeStructure.alias = CodeStructure.WithAlias (CompatGHC.mkModuleName "Foo")+ , CodeStructure.safe = CodeStructure.withoutSafe+ , CodeStructure.packageQualification = CodeStructure.WithPackageQualifier "unliftio"+ }+ }+ ]+ )+ ]+ , Checks.importChecksAllowedOpenUnaliasedImports = Rules.Enforced 2+ , Checks.importChecksAllowedAliasUniqueness =+ Just . CodeStructure.AllAliasesUniqueExcept $+ CodeStructure.AliasUniquenessExceptions+ (Set.singleton $ CompatGHC.mkModuleName "Export")+ Rules.noUserNote+ }++importPatternWithIgnoresModuleRules :: Checks.ImportChecks+importPatternWithIgnoresModuleRules =+ Checks.ImportChecks+ { Checks.importChecksTreeDependencies = Nothing+ , Checks.importChecksEncapsulatedTrees = Nothing+ , Checks.importChecksAllowedQualifications = mempty+ , Checks.importChecksAllowedOpenUnaliasedImports = Rules.NotEnforced+ , Checks.importChecksAllowedAliasUniqueness = Nothing+ }++importSpecifiedModuleRules :: Checks.ImportChecks+importSpecifiedModuleRules =+ Checks.ImportChecks+ { Checks.importChecksTreeDependencies =+ Just . pure $+ Checks.CheckedDependency+ (CodeStructure.parse "Control.Monad")+ Rules.noUserNote+ (CodeStructure.parse "PetStore")+ , Checks.importChecksEncapsulatedTrees =+ Just+ (pure (CodeStructure.parse "Service.ThirdPartyPetsSite"))+ , Checks.importChecksAllowedQualifications =+ Map.fromList+ [+ ( CompatGHC.mkModuleName "UnliftIO"+ ,+ [ CodeStructure.SchemeWithNote+ { CodeStructure.schemeNote = Rules.noUserNote+ , CodeStructure.underlyingScheme =+ CodeStructure.Scheme+ { CodeStructure.qualification = CompatGHC.QualifiedPre+ , CodeStructure.alias = CodeStructure.WithAlias (CompatGHC.mkModuleName "Foo")+ , CodeStructure.safe = CodeStructure.withoutSafe+ , CodeStructure.packageQualification = CodeStructure.WithPackageQualifier "unliftio"+ }+ }+ , CodeStructure.SchemeWithNote+ { CodeStructure.schemeNote = Rules.noUserNote+ , CodeStructure.underlyingScheme =+ CodeStructure.Scheme+ { CodeStructure.qualification = CompatGHC.QualifiedPost+ , CodeStructure.alias = CodeStructure.WithAlias (CompatGHC.mkModuleName "Foo")+ , CodeStructure.safe = CodeStructure.withoutSafe+ , CodeStructure.packageQualification = CodeStructure.WithPackageQualifier "unliftio"+ }+ }+ ]+ )+ ]+ , Checks.importChecksAllowedOpenUnaliasedImports = Rules.Enforced 20+ , Checks.importChecksAllowedAliasUniqueness =+ Just . CodeStructure.AllAliasesUniqueExcept $+ CodeStructure.AliasUniquenessExceptions+ (Set.singleton $ CompatGHC.mkModuleName "Export")+ Rules.noUserNote+ }