guardian 0.4.0.0 → 0.5.0.0
raw patch · 21 files changed
+1159/−407 lines, 21 filesdep +bytestring-triedep +case-insensitivedep +language-dotdep −arraydep −microlensdep −selectivedep ~cabal-install
Dependencies added: bytestring-trie, case-insensitive, language-dot, parsec, regex-applicative-text, tasty-expected-failure, typed-process
Dependencies removed: array, microlens, selective
Dependency ranges changed: cabal-install
Files
- ChangeLog.md +16/−0
- README.md +89/−6
- guardian.cabal +63/−13
- src/Development/Guardian/App.hs +47/−16
- src/Development/Guardian/Flags.hs +17/−0
- src/Development/Guardian/Graph.hs +57/−63
- src/Development/Guardian/Graph/Adapter/Cabal.hs +7/−115
- src/Development/Guardian/Graph/Adapter/Cabal/Disabled.hs +18/−0
- src/Development/Guardian/Graph/Adapter/Cabal/Enabled.hs +90/−0
- src/Development/Guardian/Graph/Adapter/Cabal/Types.hs +41/−0
- src/Development/Guardian/Graph/Adapter/Custom.hs +208/−0
- src/Development/Guardian/Graph/Adapter/Detection.hs +4/−4
- src/Development/Guardian/Graph/Adapter/Stack.hs +7/−119
- src/Development/Guardian/Graph/Adapter/Stack/Disabled.hs +21/−0
- src/Development/Guardian/Graph/Adapter/Stack/Enabled.hs +108/−0
- src/Development/Guardian/Graph/Adapter/Stack/Types.hs +27/−0
- src/Development/Guardian/Graph/Adapter/Types.hs +2/−4
- src/Development/Guardian/Types.hs +100/−13
- src/Text/Pattern.hs +115/−0
- test/Development/Guardian/AppSpec.hs +105/−54
- test/Development/Guardian/Test/Flags.hs +17/−0
ChangeLog.md view
@@ -1,5 +1,21 @@ # Changelog for guardian ++## 0.5.0.0++- Now guaridan can talk with external program to get a dependency graph!+ + Currently, it supports Dot language as the only input format.+ + This enables you to use guardian to maintain:+ - non-Haskell projects+ - the dependency between arbitrary entities not limited to packages, e.g. modules.+ + See [`./dependency-domains-graphmod.yaml`](./dependency-domains-graphmod.yaml) for the example usage in conjunction with `graphmod` to maintain _module_ dependecy boundaries.+- Implements `wildcards` section: if `wildcards: true` is specified, you can use wildcard `*` in your domain entity definition.+ + You cannot use wildcards in exceptional rule targets; this is intentional.+- Supports conditional builds: when you build guardian manually, you can disable unnecessary adapters.+ Just turn off `cabal` and/or `stack` flags to disable corresponding adapters.+- Rework on GitHub Actions.+- Bumps up Cabal and Stack version. This should address the error when CABAL_DIR is not set to `~/.cabal`.+ ## 0.4.0.0 - This is the first official OSS release! :tada:
README.md view
@@ -1,6 +1,12 @@ # guardian - The border guardian for your package dependencies -- [Introduction - How to keep your Haskell monorepo sane](#introduction---how-to-keep-your-haskell-monorepo-sane)+[](https://github.com/deepflowinc/guardian/actions/workflows/haskell.yml)+++Guardian enforces dependency boundary constraints and keeps your project dependencies sane.+Mainly designed to apply to the package dependencies internal of a large Haskell monorepo, but it can also be used with monorepos in other/multi languages or at the level of modules.++- [Introduction - How to keep your monorepo sane](#introduction---how-to-keep-your-monorepo-sane) + [Dependency Inversion Principle](#dependency-inversion-principle) + [The emergence of Guardian - package dependency domain isolation in practice](#the-emergence-of-guardian---package-dependency-domain-isolation-in-practice) + [Summary](#summary)@@ -12,14 +18,16 @@ - [Component Section](#component-section) - [Cabal specific settings](#cabal-specific-settings) - [Stack specific settings](#stack-specific-settings)+ - [Custom adapter settings](#custom-adapter-settings)+ + [Current limitation](#current-limitation) - [Example Configuration](#example-configuration) - [GitHub Actions](#github-actions) - [Contribution](#contribution) - [Copyright](#copyright) -## Introduction - How to keep your Haskell monorepo sane+## Introduction - How to keep your monorepo sane -Maintaining a large monorepo consisting of dozens of Haskell packages is not easy.+Maintaining a large monorepo consisting of dozens of packages is not easy. Sometimes, just making sure all packages compile on CI is not enough - to accelerate the development cycle, it is crucial to ensure that changes to the codebase trigger only necessary rebuilds as far as possible. But enforcing this requirement by hand is not easy.@@ -292,9 +300,12 @@ - `stack`: uses Stack (>= 2.9) as an adapter. - `cabal`: uses cabal-install (>= 3.8) as an adapter.-- `auto`: determines adapter based on the directory contents and guardian configuration.+- `auto`: determines adapter based on the directory contents and guardian configuration. Currently, it chooses an adapter from `stack` or `cabal`. + If exactly one of `cabal.project` or `stack.yaml` is found, use the corresponding build system as an adapter. + If exactly one of the custom config sections (say, `cabal:` or `stack:`) is found in the config file, use the corresponding build system.+- `custom`: uses the user-specified external process as an adapter.+ With this adapter, you can check dependency between arbitrary entities in any language.+ See the [Custom adapter settings](#custom-adapter-settings) section for more detail. Note that `guardian` links directly to `stack` and `cabal-install`, so you don't need those binaries. Make sure the project configuration is compatible with the above version constraint.@@ -322,6 +333,7 @@ | Section | Description | | --------- | ----------- | | `domains` | **Required**. Definition of Dependency Domains (see [Domain Definition](#domain-definition)) |+| `wildcards` | _Optional_. If `true`, package name can contain wildcards `*`, which matches arbitrary string (when enabled and you need the literal character `*`, use `\*`). Note that even if this option is set, you CANNOT use `*` in exception rule targets. (Default: `false`) | | `components` | _Optional_. Configuration whether track test/benchmark dependencies as well (see [Component Section](#component-section)) | | `cabal` | _Optional_. Cabal-specific configurations. (see [Cabal specific settings](#cabal-specific-settings)) | | `stack` | _Optional_. Stack-specific configurations. (see [stack specific settings](#stack-specific-settings)) |@@ -393,7 +405,6 @@ | `tests` | `Bool` | _Optional_. If `true`, tracks tests (default: `true`). | | `benchmarks` | `Bool` | _Optional_. If `true`, tracks benchmarks (default: `true`). | - The `component` section itself can be omitted - in such cases, all the tests and benchmarks will be tracked for dependency. #### Cabal specific settings@@ -437,6 +448,78 @@ If the `stack` section is omitted, the `options` will be treated as empty. +#### Custom adapter settings++This is the most general adapter: it reads a dependency graph from STDOUT of an external process.+This adapter allows you to enforce dependency boundary constraints for _any entity in any language_, provided that there is an external program that emits dependency graph (currently in [Dot][dot-lang] language).++[dot-lang]: https://graphviz.org/doc/info/lang.html++For example:++- You can write custom shell script to emit a package dependency graph for the build system you use.+ For example, Bazel provides [the `query --output graph` command][bazel query].+- You can use [`graphmod`][graphmod] to enforce Haskell *module* dependency domain constraints.+ See [`./dependency-domains-graphmod.yaml`](./dependency-domains-graphmod.yaml) for such an example.++[graphmod]: https://hackage.haskell.org/package/graphmod+[bazel query]: https://bazel.build/query/guide++The custom adapter sets the following environmental variables when invoking external process:++| Variable | Description |+| -------- | ----------- |+| `GUARDIAN_ROOT_DIR` | The path to the project root to check dependencies |+| `GUARDIAN_INCLUDE_TESTS` | Set to `1` if `components.tests` is enabeld; otherwise unset. |+| `GUARDIAN_INCLUDE_BENCHMARKS` | Set to `1` if `components.benchmarks` is enabled; otherwise unset. |++Guardian will parse the standard output of the process as a [Dot][dot-lang] program and regard it as a dependency graph.++You can configure the custom adapter in the `custom` top-level section in the configuration file.+It has the following fields:++| Field | Type | Description |+| ----- | ---- | ----------- |+| `program` | `Path` | _Exactly one of `program` or `shell` must be specified_. Specifies the path to the external program to use as an adapter. Beside the environmental variables mentioned above, it passes the project root as the first argument. The path must be point to an executable file and has the right permission. See also `command`. |+| `shell` | `String` | _Exactly one of `program` or `shell` must be specified_. You can specify shell script instead of the path to the program. See also `program`. |+| `ignore_loop` | `Bool` | _Optional_. If `true`, gurdian ignores self-loops in the dependency graph. (default: `false`) |++An example setting with the `shell` field:++```yaml+custom:+ shell: |+ stack dot --no-external --no-include-base 2>/dev/null+```++An example with the `program` field:++```yaml+custom:+ program: "./decode-cabal-plan.sh"+ ignore_loop: true+```++with `decode-cabal-plan.sh:`++```sh+#!/bin/bash+cabal-plan --hide-builtin --hide-global dot 2>/dev/null \+ | sed -r 's/:(test|benchmark|exe):[^\"]+//g; s/-[0-9]+(\.[0-9]+)*//g'+```++An example calling `graphmod`:++```yaml+custom:+ shell: graphmod --no-cluster 2>/dev/null # --no-cluster is needed to avoid subgraphs+```++##### Current limitation++- Only [Dot][dot-lang] format is supported.+- Custom adapter silently ignores subgraphs in a dot file.+ #### Example Configuration ```yaml@@ -500,7 +583,7 @@ continue-on-error: true steps: - uses: actions/checkout@v3- - uses: haskell/actions/setup@v2+ - uses: haskell-actions/setup@v2 with: ghc-version: 9.0.2 # Install needed version of ghc - uses: deepflowinc/guardian/action@v0.4.0.0
guardian.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: guardian-version: 0.4.0.0+version: 0.5.0.0 synopsis: The border guardian for your package dependencies description: Guardian secures your Haskell monorepo package dependency boundary. Please read [README.md](https://github.com/deepflowinc/guardian#readme) for more details. category: Development@@ -26,31 +26,54 @@ type: git location: https://github.com/deepflowinc/guardian +flag cabal+ description: Enables Cabal adapter+ manual: True+ default: True++flag stack+ description: Enables Cabal adapter+ manual: True+ default: True++flag test-cabal-plan+ description: Enables testcases for custom+cabal-plan+ manual: True+ default: True++flag test-graphmod+ description: Enables testcases for custom+cabal-plan+ manual: True+ default: True+ library exposed-modules: Development.Guardian.App Development.Guardian.Constants+ Development.Guardian.Flags Development.Guardian.Graph Development.Guardian.Graph.Adapter.Cabal+ Development.Guardian.Graph.Adapter.Cabal.Types+ Development.Guardian.Graph.Adapter.Custom Development.Guardian.Graph.Adapter.Detection Development.Guardian.Graph.Adapter.Stack+ Development.Guardian.Graph.Adapter.Stack.Types Development.Guardian.Graph.Adapter.Types Development.Guardian.Types+ Text.Pattern other-modules: Paths_guardian autogen-modules: Paths_guardian hs-source-dirs: src- ghc-options: -Wall+ ghc-options: -Wall -Wunused-packages build-depends:- Cabal- , Cabal-syntax- , aeson+ aeson , algebraic-graphs- , array , base >=4.7 && <5- , cabal-install >=3.8+ , bytestring-trie+ , case-insensitive , containers , dlist , generic-lens@@ -58,22 +81,44 @@ , hashable , indexed-traversable , indexed-traversable-instances- , microlens+ , language-dot , optparse-applicative+ , parsec , path , path-io+ , regex-applicative-text , rio- , selective , semigroups- , stack >=2.9 , template-haskell , text , transformers+ , typed-process , unordered-containers , validation-selective , vector , yaml default-language: Haskell2010+ if flag(cabal)+ other-modules:+ Development.Guardian.Graph.Adapter.Cabal.Enabled+ cpp-options: -DENABLE_CABAL+ build-depends:+ Cabal+ , Cabal-syntax+ , cabal-install+ else+ other-modules:+ Development.Guardian.Graph.Adapter.Cabal.Disabled+ if flag(stack)+ other-modules:+ Development.Guardian.Graph.Adapter.Stack.Enabled+ cpp-options: -DENABLE_STACK+ build-depends:+ Cabal+ , stack >=2.9+ else+ other-modules:+ Development.Guardian.Graph.Adapter.Stack.Disabled executable guardian main-is: Main.hs@@ -83,11 +128,10 @@ Paths_guardian hs-source-dirs: app- ghc-options: -Wall+ ghc-options: -Wall -Wunused-packages build-depends: base >=4.7 && <5 , guardian- , text default-language: Haskell2010 test-suite guardian-test@@ -99,12 +143,13 @@ Development.Guardian.Graph.Adapter.StackSpec Development.Guardian.Graph.Adapter.TestUtils Development.Guardian.GraphSpec+ Development.Guardian.Test.Flags Paths_guardian autogen-modules: Paths_guardian hs-source-dirs: test- ghc-options: -Wall+ ghc-options: -Wall -Wunused-packages build-tool-depends: tasty-discover:tasty-discover build-depends:@@ -117,8 +162,13 @@ , path-io , rio , tasty+ , tasty-expected-failure , tasty-hunit , text , unordered-containers , validation-selective default-language: Haskell2010+ if flag(test-cabal-plan)+ cpp-options: -DTEST_CABAL_PLAN+ if flag(test-graphmod)+ cpp-options: -DTEST_GRAPHMOD
src/Development/Guardian/App.hs view
@@ -14,6 +14,7 @@ buildInfoQ, ) where +import qualified Algebra.Graph as G import Control.Applicative ((<**>)) import qualified Data.Aeson as J import Data.Foldable.WithIndex@@ -26,8 +27,10 @@ import Data.Version (Version (..), showVersion) import qualified Data.Yaml as Y import Development.Guardian.Constants (configFileName)+import Development.Guardian.Flags import Development.Guardian.Graph import qualified Development.Guardian.Graph.Adapter.Cabal as Cabal+import qualified Development.Guardian.Graph.Adapter.Custom as Custom import Development.Guardian.Graph.Adapter.Detection (detectAdapterThrow) import qualified Development.Guardian.Graph.Adapter.Stack as Stack import Development.Guardian.Graph.Adapter.Types@@ -61,7 +64,7 @@ ||] optsPI :: BuildInfo -> Opts.ParserInfo Option-optsPI BuildInfo {..} = Opts.info (p <**> Opts.helper <**> versions) mempty+optsPI BuildInfo {..} = Opts.info (p <**> Opts.helper <**> versions <**> numericVersion) mempty where gitRev = maybe@@ -72,7 +75,16 @@ <> if giDirty gi then " (dirty)" else "" ) gitInfo- verStr = "Guardian Version " <> versionString <> gitRev+ verStr =+ "Guardian Version "+ <> versionString+ <> gitRev+ <> " (cabal adapter: "+ <> show cabalEnabled+ <> ", stack adapter: "+ <> show stackEnabled+ <> ")"+ numericVersion = Opts.infoOption versionString (Opts.long "numeric-version" <> Opts.short 'V' <> Opts.help "Prints numeric version and exit.") versions = Opts.infoOption verStr (Opts.long "version" <> Opts.short 'V' <> Opts.help "Prints version string and exit.") inP mode = do config <-@@ -95,19 +107,28 @@ p = Opts.hsubparser- ( mconcat- [ Opts.command "auto" autoP- , Opts.command- "stack"- ( Opts.info (inP $ Just Stack) $- Opts.progDesc "Defends borders against stack.yaml"- )- , Opts.command- "cabal"- ( Opts.info (inP $ Just Cabal) $- Opts.progDesc "Defends borders against cabal.project"- )- ]+ ( mconcat $+ [Opts.command "auto" autoP]+ ++ [ Opts.command+ "stack"+ ( Opts.info (inP $ Just Stack) $+ Opts.progDesc "Defends borders against stack.yaml"+ )+ | stackEnabled+ ]+ ++ [ Opts.command+ "cabal"+ ( Opts.info (inP $ Just Cabal) $+ Opts.progDesc "Defends borders against cabal.project"+ )+ | cabalEnabled+ ]+ ++ [ Opts.command+ "custom"+ ( Opts.info (inP $ Just Custom) $+ Opts.progDesc "Defends borders with a custom adapter"+ )+ ] ) parseDirP :: String -> Either String (SomeBase Dir)@@ -139,7 +160,7 @@ targ <- maybe getCurrentDir canonicalizePath target logInfo $ "Using configuration: " <> fromString (fromRelFile config) yaml <- Y.decodeFileThrow (fromAbsFile $ targ </> config)- doms <- either throwString pure $ eitherResult $ J.fromJSON yaml+ domsCfg <- either throwString pure $ eitherResult $ J.fromJSON yaml mode' <- maybe (detectAdapterThrow yaml targ) pure mode logInfo $@@ -158,6 +179,16 @@ either throwString (Cabal.buildPackageGraph . flip withTargetPath targ) $ eitherResult $ J.fromJSON yaml+ Custom ->+ liftIO $+ either throwString (Custom.buildPackageGraph . flip withTargetPath targ) $+ eitherResult $+ J.fromJSON yaml+ let DomainResult doms mwarns = resolveDomainName domsCfg pkgGraph+ forM_ mwarns $ \warns -> do+ logWarn $ "* " <> displayShow (length warns) <> " warnings during pattern expansion:"+ logWarn $ "Available entities: " <> displayShow (G.vertexList pkgGraph)+ mapM_ (logWarn . fromString) warns reportPackageGraphValidation doms pkgGraph reportPackageGraphValidation ::
+ src/Development/Guardian/Flags.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE CPP #-}++module Development.Guardian.Flags (cabalEnabled, stackEnabled) where++cabalEnabled :: Bool+#if defined(ENABLE_CABAL)+cabalEnabled = True+#else+cabalEnabled = False+#endif++stackEnabled :: Bool+#if defined(ENABLE_STACK)+stackEnabled = True+#else+stackEnabled = False+#endif
src/Development/Guardian/Graph.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DerivingVia #-}@@ -25,39 +26,18 @@ import qualified Data.Bifunctor as Bi import Data.Coerce (coerce) import qualified Data.DList as DL+import Data.DList.DNonEmpty (DNonEmpty) import qualified Data.DList.DNonEmpty as DLNE import qualified Data.HashMap.Strict as HM import qualified Data.List.NonEmpty as NE import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map-import Data.Maybe+import Data.Monoid (Ap (..)) import Data.Semigroup.Generic import Data.Set (Set) import qualified Data.Set as Set import qualified Data.Vector as V-import Development.Guardian.Types (- ActualGraph,- CheckResult (..),- Dependency (..),- Diagnostics (Diagnostics, redundantExtraDeps, usedExceptionalRules),- Domain (Domain, dependsOn, packages),- DomainGraph,- DomainGraphError (..),- DomainInfo (..),- DomainName,- Domains (..),- Overlayed (Overlayed, getOverlayed),- PackageDef (PackageDef, extraDeps, packageName),- PackageDic,- PackageGraph,- PackageName,- PackageViolation (- CyclicPackageDep,- DomainBoundaryViolation,- UncoveredPackages- ),- isEmptyDiagnostics,- )+import Development.Guardian.Types import GHC.Generics (Generic) import Validation @@ -78,7 +58,7 @@ Overlayed (GC.vertex dom) <> maybe mempty (foldMap (Overlayed . GC.edge dom)) dependsOn )- domains+ getDomains toDomainGraph :: Domains -> Validation (NE.NonEmpty DomainGraphError) DomainGraph toDomainGraph doms =@@ -108,7 +88,7 @@ ) . packages )- domains+ getDomains newtype CatMap k v = CatMap {getCatMap :: Map k v} @@ -138,7 +118,7 @@ map (\PackageDef {..} -> (packageName, (domName, extraDeps))) $ V.toList packages )- . domains+ . getDomains matches :: PackageDic -> Dependency -> PackageName -> Bool matches pkgDic (DomainDep dn) pkg =@@ -171,50 +151,64 @@ buildActualGraphs :: PackageDic -> PackageGraph ->- ActualGraphs ActualGraph (Map PackageName (Set Dependency))+ Validation+ (DNonEmpty PackageViolation)+ (ActualGraphs ActualGraph (Map PackageName (Set Dependency))) buildActualGraphs pkgDic =- Bi.bimap- (Bi.first DL.toList . getLOverlayed)- (Map.filter (not . Set.null) . getCatMap)- . foldMap- ( \e@(src, dst) ->- let (srcDomain, srcExcept) =- fromMaybe (error $ "src, not found: " <> show (src, pkgDic)) $+ let pkgs = Map.keys pkgDic+ in fmap+ ( Bi.bimap+ (Bi.first DL.toList . getLOverlayed)+ (Map.filter (not . Set.null) . getCatMap)+ )+ . getAp+ . foldMap+ ( \e@(src, dst) -> Ap $ do+ src' <-+ maybe (failed $ OrphanPackage src pkgs) Success $ Map.lookup src pkgDic- (dstDomain, _) =- fromMaybe (error $ "dst, not found: " <> show (dst, pkgDic)) $++ (dstDomain, _) <-+ maybe (failed $ OrphanPackage dst pkgs) Success $ Map.lookup dst pkgDic- aGraph = LOverlayed $ LG.edge (DL.singleton e) srcDomain dstDomain- excepts = Set.fromList $ V.toList $ V.filter (flip (matches pkgDic) dst) srcExcept- in if Set.null excepts- then AGs {exceptionGraph = mempty, activatedGraph = aGraph}- else AGs {activatedGraph = mempty, exceptionGraph = CatMap $ Map.singleton src excepts}- )- . G.edgeList + pure $+ let (srcDomain, srcExcept) = src'+ aGraph = LOverlayed $ LG.edge (DL.singleton e) srcDomain dstDomain+ excepts = Set.fromList $ V.toList $ V.filter (flip (matches pkgDic) dst) srcExcept+ in if Set.null excepts+ then AGs {exceptionGraph = mempty, activatedGraph = aGraph}+ else AGs {activatedGraph = mempty, exceptionGraph = CatMap $ Map.singleton src excepts}+ )+ . G.edgeList++failed :: e -> Validation (DNonEmpty e) a+failed = Failure . pure+ validatePackageGraph :: DomainInfo -> PackageGraph -> Validation (NE.NonEmpty PackageViolation) CheckResult validatePackageGraph DomainInfo {..} pg = Bi.first DLNE.toNonEmpty $- resl- <$ ( case Bi.first DLNE.singleton (detectPackageCycle pg) of- f@Failure {} -> f- Success {} ->- Bi.first DLNE.singleton (coversAllPackages packageDic pg)- <* satisfiesDomainGraph domainGraph activatedGraph- )- where- AGs {..} = buildActualGraphs packageDic pg- redundantExtras = findRedundantExtraDeps packageDic pg- diags =- Diagnostics- { redundantExtraDeps =- Set.fromList . V.toList <$> redundantExtras- , usedExceptionalRules = exceptionGraph- }- resl- | isEmptyDiagnostics diags = Ok- | otherwise = OkWithDiagnostics diags+ case buildActualGraphs packageDic pg of+ Failure e -> Failure e+ Success AGs {..} ->+ let redundantExtras = findRedundantExtraDeps packageDic pg+ diags =+ Diagnostics+ { redundantExtraDeps =+ Set.fromList . V.toList <$> redundantExtras+ , usedExceptionalRules = exceptionGraph+ }+ resl+ | isEmptyDiagnostics diags = Ok+ | otherwise = OkWithDiagnostics diags+ in resl+ <$ ( case Bi.first DLNE.singleton (detectPackageCycle pg) of+ f@Failure {} -> f+ Success {} ->+ Bi.first DLNE.singleton (coversAllPackages packageDic pg)+ <* satisfiesDomainGraph domainGraph activatedGraph+ ) detectPackageCycle :: PackageGraph -> Validation PackageViolation ()
src/Development/Guardian/Graph/Adapter/Cabal.hs view
@@ -1,116 +1,8 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedLabels #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TypeFamilies #-}--module Development.Guardian.Graph.Adapter.Cabal (- buildPackageGraph,- CustomPackageOptions (..),- Cabal,-) where--import qualified Algebra.Graph as G-import Control.Applicative (optional, (<|>))-import Control.Monad (when)-import Data.Aeson (FromJSON, withObject, (.:))-import qualified Data.Aeson.KeyMap as AKM-import Data.Aeson.Types (FromJSON (..))-import Data.Either (fromLeft)-import Data.Generics.Labels ()-import qualified Data.Map.Strict as Map-import Data.Maybe-import qualified Data.Set as Set-import Data.String (fromString)-import Development.Guardian.Graph.Adapter.Types (ComponentsOptions (..), CustomPackageOptions, PackageGraphOptions (..))-import Development.Guardian.Types (Overlayed (..), PackageGraph)-import qualified Development.Guardian.Types as Guard-import Distribution.Client.CmdUpdate (updateAction)-import Distribution.Client.InstallPlan (GenericPlanPackage (..), depends)-import qualified Distribution.Client.InstallPlan as Plan-import Distribution.Client.NixStyleOptions (defaultNixStyleFlags)-import Distribution.Client.ProjectConfig (ProjectRoot (..))-import Distribution.Client.ProjectOrchestration (CurrentCommand (..), ProjectBaseContext (..), establishProjectBaseContextWithRoot, withInstallPlan)-import Distribution.Client.ProjectPlanning (ElaboratedConfiguredPackage (..), elabLocalToProject)-import Distribution.Package (Package (..), packageName, unPackageName)-import Distribution.Simple.Flag (Flag (..))-import Distribution.Verbosity (silent)-import GHC.Generics (Generic)-import Lens.Micro-import Path--data Cabal deriving (Generic)--data instance CustomPackageOptions Cabal = CabalOptions {projectFile :: Maybe (Path Rel File), update :: Maybe (Either Bool String)}- deriving (Show, Eq, Ord, Generic)--instance FromJSON (CustomPackageOptions Cabal) where- parseJSON = withObject "{cabal: ...}" $ \obj ->- if AKM.member "cabal" obj- then do- dic <- obj .: "cabal"- projectFile <- optional $ dic .: "projectFile"- update <-- if AKM.member "update" dic- then- fmap Just $- Left <$> (dic .: "update")- <|> Right <$> (dic .: "update")- else pure Nothing- pure CabalOptions {..}- else pure (CabalOptions Nothing Nothing)--buildPackageGraph :: PackageGraphOptions Cabal -> IO PackageGraph-buildPackageGraph PackageGraphOptions {customOptions = CabalOptions {..}, ..} = do- let target = fromAbsDir targetPath- mproj = fromAbsFile . (targetPath </>) <$> projectFile- root = maybe (ProjectRootImplicit target) (ProjectRootExplicit target) mproj- when (maybe False (fromLeft True) update) $ do- let targets- | Just (Right idx) <- update = [idx]- | otherwise = []- updateAction (defaultNixStyleFlags ()) targets mempty-- ctx0 <- establishProjectBaseContextWithRoot silent mempty root OtherCommand- let pjCfg' =- projectConfig ctx0- & #projectConfigLocalPackages . #packageConfigTests- .~ Flag (tests components)- & #projectConfigLocalPackages . #packageConfigBenchmarks- .~ Flag (benchmarks components)- -- ProjectBaseContext has no Generic instance...- ctx = ctx0 {projectConfig = pjCfg'}-- withInstallPlan silent ctx $ \iplan _scfg -> do- let localPkgDic =- Map.mapMaybe- ( \case- Configured pkg- | elabLocalToProject pkg -> pure pkg- Installed pkg- | elabLocalToProject pkg -> pure pkg- _ -> Nothing- )- $ Plan.toMap iplan- localUnitIds = Map.keysSet localPkgDic- gr =- getOverlayed $- foldMap- ( \pkg ->- let srcPkg = packageName' pkg- deps =- filter (/= srcPkg)- $ mapMaybe- (fmap packageName' . (`Map.lookup` localPkgDic))- $ filter (`Set.member` localUnitIds)- $ depends pkg- in foldMap (Overlayed . G.edge srcPkg) deps- )- localPkgDic- pure gr+{-# LANGUAGE CPP #-} -packageName' :: Package pkg => pkg -> Guard.PackageName-packageName' = fromString . unPackageName . packageName+module Development.Guardian.Graph.Adapter.Cabal (module Cabal) where+#if defined(ENABLE_CABAL)+import Development.Guardian.Graph.Adapter.Cabal.Enabled as Cabal+#else+import Development.Guardian.Graph.Adapter.Cabal.Disabled as Cabal+#endif
+ src/Development/Guardian/Graph/Adapter/Cabal/Disabled.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}++module Development.Guardian.Graph.Adapter.Cabal.Disabled (+ buildPackageGraph,+ CustomPackageOptions (..),+ Cabal,+) where++import Data.Generics.Labels ()+import Development.Guardian.Graph.Adapter.Cabal.Types+import Development.Guardian.Graph.Adapter.Types (PackageGraphOptions (..))+import Development.Guardian.Types (PackageGraph)++buildPackageGraph :: PackageGraphOptions Cabal -> IO PackageGraph+buildPackageGraph _ = error "Cabal backend disabled!"
+ src/Development/Guardian/Graph/Adapter/Cabal/Enabled.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-}++module Development.Guardian.Graph.Adapter.Cabal.Enabled (+ buildPackageGraph,+ CustomPackageOptions (..),+ Cabal,+) where++import qualified Algebra.Graph as G+import Control.Monad (when)+import Data.Either (fromLeft)+import Data.Function ((&))+import Data.Generics.Labels ()+import qualified Data.Map.Strict as Map+import Data.Maybe+import qualified Data.Set as Set+import Data.String (fromString)+import Development.Guardian.Graph.Adapter.Cabal.Types+import Development.Guardian.Graph.Adapter.Types (ComponentsOptions (..), PackageGraphOptions (..))+import Development.Guardian.Types (Overlayed (..), PackageGraph)+import qualified Development.Guardian.Types as Guard+import Distribution.Client.CmdUpdate (updateAction)+import Distribution.Client.InstallPlan (GenericPlanPackage (..), depends)+import qualified Distribution.Client.InstallPlan as Plan+import Distribution.Client.NixStyleOptions (defaultNixStyleFlags)+import Distribution.Client.ProjectConfig (ProjectRoot (..))+import Distribution.Client.ProjectOrchestration (CurrentCommand (..), ProjectBaseContext (..), establishProjectBaseContextWithRoot, withInstallPlan)+import Distribution.Client.ProjectPlanning (ElaboratedConfiguredPackage (..), elabLocalToProject)+import Distribution.Package (Package (..), packageName, unPackageName)+import Distribution.Simple.Flag (Flag (..))+import Distribution.Verbosity (silent)+import Path+import RIO ((.~))++buildPackageGraph :: PackageGraphOptions Cabal -> IO PackageGraph+buildPackageGraph PackageGraphOptions {customOptions = CabalOptions {..}, ..} = do+ let target = fromAbsDir targetPath+ mproj = fromAbsFile . (targetPath </>) <$> projectFile+ root = maybe (ProjectRootImplicit target) (ProjectRootExplicit target) mproj+ when (maybe False (fromLeft True) update) $ do+ let targets+ | Just (Right idx) <- update = [idx]+ | otherwise = []+ updateAction (defaultNixStyleFlags ()) targets mempty++ ctx0 <- establishProjectBaseContextWithRoot silent mempty root OtherCommand+ let pjCfg' =+ projectConfig ctx0+ & #projectConfigLocalPackages . #packageConfigTests+ .~ Flag (tests components)+ & #projectConfigLocalPackages . #packageConfigBenchmarks+ .~ Flag (benchmarks components)+ -- ProjectBaseContext has no Generic instance...+ ctx = ctx0 {projectConfig = pjCfg'}++ withInstallPlan silent ctx $ \iplan _scfg -> do+ let localPkgDic =+ Map.mapMaybe+ ( \case+ Configured pkg+ | elabLocalToProject pkg -> pure pkg+ Installed pkg+ | elabLocalToProject pkg -> pure pkg+ _ -> Nothing+ )+ $ Plan.toMap iplan+ localUnitIds = Map.keysSet localPkgDic+ gr =+ getOverlayed $+ foldMap+ ( \pkg ->+ let srcPkg = packageName' pkg+ deps =+ filter (/= srcPkg)+ $ mapMaybe+ (fmap packageName' . (`Map.lookup` localPkgDic))+ $ filter (`Set.member` localUnitIds)+ $ depends pkg+ in foldMap (Overlayed . G.edge srcPkg) deps+ )+ localPkgDic+ pure gr++packageName' :: Package pkg => pkg -> Guard.PackageName+packageName' = fromString . unPackageName . packageName
+ src/Development/Guardian/Graph/Adapter/Cabal/Types.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-}++module Development.Guardian.Graph.Adapter.Cabal.Types (+ CustomPackageOptions (..),+ Cabal,+) where++import Control.Applicative (optional, (<|>))+import Data.Aeson (FromJSON, withObject, (.:))+import qualified Data.Aeson.KeyMap as AKM+import Data.Aeson.Types (FromJSON (..))+import Data.Generics.Labels ()+import Development.Guardian.Graph.Adapter.Types (CustomPackageOptions)+import GHC.Generics (Generic)+import Path++data Cabal deriving (Generic)++data instance CustomPackageOptions Cabal = CabalOptions {projectFile :: Maybe (Path Rel File), update :: Maybe (Either Bool String)}+ deriving (Show, Eq, Ord, Generic)++instance FromJSON (CustomPackageOptions Cabal) where+ parseJSON = withObject "{cabal: ...}" $ \obj ->+ if AKM.member "cabal" obj+ then do+ dic <- obj .: "cabal"+ projectFile <- optional $ dic .: "projectFile"+ update <-+ if AKM.member "update" dic+ then+ fmap Just $+ Left <$> (dic .: "update")+ <|> Right <$> (dic .: "update")+ else pure Nothing+ pure CabalOptions {..}+ else pure (CabalOptions Nothing Nothing)
+ src/Development/Guardian/Graph/Adapter/Custom.hs view
@@ -0,0 +1,208 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-}++module Development.Guardian.Graph.Adapter.Custom (+ Custom,+ buildPackageGraph,+ CustomPackageOptions (..),+ CustomAdapterException (..),+ fromDotGraph,+) where++import qualified Algebra.Graph as G+import Control.Applicative (liftA2, (<|>))+import Control.Exception (Exception, throwIO)+import Control.Monad (when)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.Aeson (FromJSON)+import qualified Data.Aeson as J+import qualified Data.Bifunctor as Bi+import qualified Data.CaseInsensitive as CI+import qualified Data.DList.DNonEmpty as DLNE+import Data.Function (on, (&))+import Data.Functor ((<&>))+import Data.List.NonEmpty (NonEmpty)+import qualified Data.List.NonEmpty as NE+import qualified Data.Map as Map+import Data.Maybe (fromMaybe)+import Data.Monoid (Ap (..))+import Data.String (IsString (..))+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Lazy as LT+import qualified Data.Text.Lazy.Encoding as LT+import Development.Guardian.Graph.Adapter.Types+import Development.Guardian.Types+import GHC.Generics (Generic)+import Language.Dot (parseDot)+import qualified Language.Dot as Dot+import Path (File, SomeBase, fromAbsDir, fromAbsFile)+import Path.IO (makeAbsolute)+import RIO (tshow)+import System.Environment (getEnvironment)+import System.Process.Typed (ProcessConfig, proc, readProcessStdout_, setEnv, shell)+import qualified Text.Parsec as Parsec+import Validation++data Custom++newtype instance CustomPackageOptions Custom = CustomOptions {custom :: CustomOpts}+ deriving (Show, Eq, Ord, Generic)+ deriving anyclass (J.FromJSON)++data CustomOpts = CustomOpts+ { adapter :: ExternalProcess+ , ignoreLoop :: Bool+ }+ deriving (Show, Eq, Ord, Generic)++instance FromJSON CustomOpts where+ parseJSON = J.withObject "dict" $ \obj -> do+ adapter <-+ Shell <$> (obj J..: "shell")+ <|> Program <$> (obj J..: "program")+ ignoreLoop <- obj J..:? "ignore_loop" J..!= False+ pure CustomOpts {..}++data ExternalProcess = Shell Text | Program (SomeBase File)+ deriving (Show, Eq, Ord, Generic)++createExternalAdapter ::+ MonadIO m =>+ PackageGraphOptions Custom ->+ m (ProcessConfig () () ())+createExternalAdapter PackageGraphOptions {..} = do+ env0 <- liftIO getEnvironment+ cfg0 <- case adapter $ custom customOptions of+ Shell txt ->+ pure $ shell $ fromString $ T.unpack txt+ Program prog -> do+ progAbs <- makeAbsolute prog+ pure $ proc (fromAbsFile progAbs) [fromAbsDir targetPath]+ let componentEnvs =+ [(includeTestVar, "1") | tests components]+ ++ [(includeBenchVar, "1") | benchmarks components]+ env' =+ ("GUARDIAN_ROOT_DIR", fromAbsDir targetPath)+ : componentEnvs+ ++ filter ((`notElem` [includeTestVar, includeBenchVar]) . fst) env0+ pure $ cfg0 & setEnv env'++includeBenchVar :: String+includeBenchVar = "GUARDIAN_INCLUDE_BENCHMARKS"++includeTestVar :: String+includeTestVar = "GUARDIAN_INCLUDE_TESTS"++data CustomAdapterException+ = InvalidAdapterOutput String Parsec.ParseError+ | InvalidGraph String Dot.Graph (NonEmpty GraphViolation)+ deriving (Eq, Generic)+ deriving anyclass (Exception)++instance Show CustomAdapterException where+ showsPrec d exc = showParen (d > 10) $+ case exc of+ InvalidAdapterOutput src pe ->+ showString "Parse error in adapter output:\n"+ . showString "Error: \n"+ . showString (unlines $ map ('\t' :) $ lines $ show pe)+ . showString "Input: \n"+ . showString (unlines $ map ('\t' :) $ lines src)+ InvalidGraph src gr ne ->+ showString "Invalid Dot Graph was passed: "+ . shows (NE.toList ne)+ . showString "\nParsedGraph:\n\t"+ . shows gr+ . showString "\nInput:\n"+ . showString (unlines $ map ('\t' :) $ lines src)++data GraphViolation+ = DirectedGraphExpected+ | EdgeToSubgraphNotSupported (Maybe Dot.Id)+ | MultiEdgeNotSupported [String]+ deriving (Show, Eq, Ord, Generic)+ deriving anyclass (Exception)++buildPackageGraph :: PackageGraphOptions Custom -> IO PackageGraph+buildPackageGraph opts = do+ pc <- createExternalAdapter opts+ src <- LT.unpack . LT.decodeUtf8 <$> readProcessStdout_ pc+ gr <- either (throwIO . InvalidAdapterOutput src) pure $ parseDot "<adapter output>" src+ let pkgGr = fromDotGraph (custom $ customOptions opts) gr+ either (throwIO . InvalidGraph src gr) pure pkgGr++data DotEntity = DotId Text | Pkg PackageName+ deriving (Show, Eq, Ord, Generic)++fromDotGraph :: CustomOpts -> Dot.Graph -> Either (NonEmpty GraphViolation) PackageGraph+fromDotGraph CustomOpts {..} (Dot.Graph _ dir _ stmts) =+ Bi.first DLNE.toNonEmpty $+ validationToEither $+ when+ (dir /= Dot.DirectedGraph)+ (failed DirectedGraphExpected)+ *> getAp (foldMap (Ap . (liftA2 (,) <$> go <*> (pure . buildDic))) stmts)+ <&> \(gr0, dic) ->+ fmap+ ( \case+ DotId txt -> fromMaybe (PackageName txt) $ Map.lookup txt dic+ Pkg pn -> pn+ )+ gr0+ where+ buildDic (Dot.NodeStatement ni atts) =+ Map.singleton (prettyNodeId ni) $ parseNode ni atts+ buildDic _ = mempty+ go (Dot.NodeStatement ni atts) =+ pure $+ G.vertex $+ Pkg $+ parseNode ni atts+ go (Dot.EdgeStatement [l, r] _)+ | ignoreLoop, parseEntity l == parseEntity r = mempty+ | otherwise =+ (G.connect `on` G.vertex) <$> parseEntity l <*> parseEntity r+ go (Dot.EdgeStatement ents _) =+ failed $ MultiEdgeNotSupported $ map (show . Dot.pp) ents+ go Dot.AttributeStatement {} = pure mempty+ go Dot.AssignmentStatement {} = pure mempty+ go Dot.SubgraphStatement {} = mempty++prettyNodeId :: Dot.NodeId -> Text+prettyNodeId (Dot.NodeId ni _) = prettyId ni++parseNode :: Dot.NodeId -> [Dot.Attribute] -> PackageName+parseNode (Dot.NodeId origId _) attrs =+ PackageName $+ prettyId $+ fromMaybe origId $+ lookup+ (CI.mk "label")+ [ (CI.mk $ prettyId l, v)+ | Dot.AttributeSetValue l v <- attrs+ ]++prettyId :: Dot.Id -> Text+prettyId (Dot.NameId s) = T.pack s+prettyId (Dot.StringId s) = T.pack s+prettyId (Dot.IntegerId n) = tshow n+prettyId (Dot.FloatId x) = tshow x+prettyId (Dot.XmlId xml) = tshow $ Dot.pp xml++failed :: e -> Validation (DLNE.DNonEmpty e) b+failed = Failure . DLNE.singleton++parseEntity :: Dot.Entity -> Validation (DLNE.DNonEmpty GraphViolation) DotEntity+parseEntity (Dot.ENodeId _ (Dot.NodeId ni _)) = pure $ DotId $ prettyId ni+parseEntity (Dot.ESubgraph _ sub) = failed $ EdgeToSubgraphNotSupported $ subGraphId sub++subGraphId :: Dot.Subgraph -> Maybe Dot.Id+subGraphId (Dot.NewSubgraph mid _) = mid+subGraphId (Dot.SubgraphRef ident) = Just ident
src/Development/Guardian/Graph/Adapter/Detection.hs view
@@ -23,7 +23,7 @@ import RIO data DetectionFailure- = BothCabalAndStackSectionsPresentInConfigYaml+ = MultipleAdapterConfigFound | BothCabalProjectAndStackYamlFound | NeitherCabalProjectNorStackYamlFound | NoCustomConfigSpecified@@ -31,8 +31,8 @@ deriving (Show, Eq, Ord, Generic) instance Exception DetectionFailure where- displayException BothCabalAndStackSectionsPresentInConfigYaml =- "Could not determine adapter: dependency-domain.yml contains both cabal and stack configuration"+ displayException MultipleAdapterConfigFound =+ "Could not determine adapter: dependency-domain.yml contains multiple adapter configs" displayException BothCabalProjectAndStackYamlFound = "Could not determine adapter: Both cabal.project and stack.yaml found" displayException NeitherCabalProjectNorStackYamlFound =@@ -89,7 +89,7 @@ let cabalPresent = AKM.member "cabal" dic stackPresent = AKM.member "stack" dic if- | cabalPresent && stackPresent -> Left BothCabalAndStackSectionsPresentInConfigYaml+ | cabalPresent && stackPresent -> Left MultipleAdapterConfigFound | cabalPresent -> Right Cabal | stackPresent -> Right Stack | otherwise -> Left NoCustomConfigSpecified
src/Development/Guardian/Graph/Adapter/Stack.hs view
@@ -1,123 +1,11 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE CPP #-} module Development.Guardian.Graph.Adapter.Stack (- buildPackageGraphM,- buildPackageGraph,- Stack,- CustomPackageOptions (..),+ module Stack, ) where -import qualified Algebra.Graph as G-import Control.Applicative ((<**>))-import Data.Aeson (FromJSON (parseJSON))-import qualified Data.Aeson as J-import Data.Maybe (fromMaybe)-import Data.Set (Set)-import qualified Data.Set as Set-import Data.String (fromString)-import Data.Text (Text)-import qualified Data.Text as T-import Development.Guardian.Graph.Adapter.Types-import Development.Guardian.Types (Overlayed (Overlayed, getOverlayed), PackageGraph)-import qualified Development.Guardian.Types as Guard-import Distribution.Simple (unPackageName)-import GHC.Generics (Generic)-import Options.Applicative (helper)-import qualified Options.Applicative as Opt-import Path (fromAbsDir)-import Path.IO (withCurrentDir)-import Stack.Build.Source (loadLocalPackage)-import Stack.Options.GlobalParser (globalOptsFromMonoid, globalOptsParser)-import Stack.Options.Utils (GlobalOptsContext (OuterGlobalOpts))-import Stack.Prelude (RIO, toList, view)-import qualified Stack.Prelude as Stack-import Stack.Runners (ShouldReexec (NoReexec), withConfig, withDefaultEnvConfig, withRunnerGlobal)-import Stack.Types.Build (LocalPackage)-import Stack.Types.Config (HasBuildConfig, HasSourceMap (sourceMapL))-import Stack.Types.Package (LocalPackage (..), Package (..))-import qualified Stack.Types.Package as Stack-import Stack.Types.SourceMap (SourceMap (..))--data Stack--newtype instance CustomPackageOptions Stack = StackOptions {stackOptions :: [Text]}- deriving (Show, Eq, Ord, Generic)--instance FromJSON (CustomPackageOptions Stack) where- parseJSON = J.withObject "{stack: }" $ \obj -> do- stack <- obj J..:? "stack"- case stack of- Nothing -> pure $ StackOptions []- Just dic -> StackOptions <$> dic J..:? "options" J..!= []--localPackageToPackage :: LocalPackage -> Package-localPackageToPackage lp =- fromMaybe (lpPackage lp) (lpTestBench lp)--{- | Resolve the direct (depth 0) external dependencies of the given local packages (assumed to come from project packages)--Stolen from @stack@ and further simplified.--}-projectPackageDependencies ::- [LocalPackage] -> [(Stack.PackageName, Set Stack.PackageName)]-projectPackageDependencies locals =- map- ( \lp ->- let pkg = localPackageToPackage lp- in (Stack.packageName pkg, deps pkg)- )- locals- where- deps pkg =- Set.intersection localNames (packageAllDeps pkg)- localNames = Set.fromList $ map (Stack.packageName . lpPackage) locals--buildPackageGraph :: PackageGraphOptions Stack -> IO PackageGraph-buildPackageGraph PackageGraphOptions {customOptions = StackOptions {..}, ..} = do- withCurrentDir targetPath $ do- let pInfo =- Opt.info- (globalOptsParser (fromAbsDir targetPath) OuterGlobalOpts Nothing <**> helper)- mempty- cliOpts =- "--skip-ghc-check"- : concat- [ ["--test", "--no-run-tests"]- | tests components- ]- <> concat- [ ["--bench", "--no-run-benchmarks"]- | benchmarks components- ]- ++ map T.unpack stackOptions- Just gopt <-- mapM (globalOptsFromMonoid False) $- Opt.getParseResult $- Opt.execParserPure (Opt.prefs mempty) pInfo cliOpts-- withRunnerGlobal gopt $- withConfig NoReexec $- withDefaultEnvConfig buildPackageGraphM--buildPackageGraphM ::- (HasSourceMap env, HasBuildConfig env) =>- RIO env PackageGraph-buildPackageGraphM = do- sourceMap <- view sourceMapL- locals <- mapM loadLocalPackage $ toList $ smProject sourceMap- let gr = projectPackageDependencies locals- pure $- getOverlayed $- foldMap- ( \(fromStackPackageName -> pkg, deps) ->- foldMap (Overlayed . G.edge pkg . fromStackPackageName) deps- )- gr--fromStackPackageName :: Stack.PackageName -> Guard.PackageName-fromStackPackageName = fromString . unPackageName+#if defined(ENABLE_STACK)+import Development.Guardian.Graph.Adapter.Stack.Enabled as Stack+#else+import Development.Guardian.Graph.Adapter.Stack.Disabled as Stack+#endif
+ src/Development/Guardian/Graph/Adapter/Stack/Disabled.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}++module Development.Guardian.Graph.Adapter.Stack.Disabled (+ buildPackageGraphM,+ buildPackageGraph,+ Stack,+ CustomPackageOptions (..),+) where++import Development.Guardian.Graph.Adapter.Stack.Types+import Development.Guardian.Graph.Adapter.Types+import Development.Guardian.Types (PackageGraph)+import RIO (RIO)++buildPackageGraph :: PackageGraphOptions Stack -> IO PackageGraph+buildPackageGraph _ = error "buildPackageGraph: Stack adapter is disabled"++buildPackageGraphM :: RIO env PackageGraph+buildPackageGraphM = error "buildPackageGraphM: Stack adapter is disabled"
+ src/Development/Guardian/Graph/Adapter/Stack/Enabled.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++module Development.Guardian.Graph.Adapter.Stack.Enabled (+ buildPackageGraphM,+ buildPackageGraph,+ Stack,+ CustomPackageOptions (..),+) where++import qualified Algebra.Graph as G+import Control.Applicative ((<**>))+import Data.Maybe (fromMaybe)+import Data.Set (Set)+import qualified Data.Set as Set+import Data.String (fromString)+import qualified Data.Text as T+import Development.Guardian.Graph.Adapter.Stack.Types+import Development.Guardian.Graph.Adapter.Types+import Development.Guardian.Types (Overlayed (Overlayed, getOverlayed), PackageGraph)+import qualified Development.Guardian.Types as Guard+import Distribution.Simple (unPackageName)+import Options.Applicative (helper)+import qualified Options.Applicative as Opt+import Path (fromAbsDir)+import Path.IO (withCurrentDir)+import Stack.Build.Source (loadLocalPackage)+import Stack.Options.GlobalParser (globalOptsFromMonoid, globalOptsParser)+import Stack.Options.Utils (GlobalOptsContext (OuterGlobalOpts))+import Stack.Prelude (RIO, toList, view)+import qualified Stack.Prelude as Stack+import Stack.Runners (ShouldReexec (NoReexec), withConfig, withDefaultEnvConfig, withRunnerGlobal)+import Stack.Types.Build (LocalPackage)+import Stack.Types.BuildConfig (HasBuildConfig)+import Stack.Types.EnvConfig (HasSourceMap (sourceMapL))+import Stack.Types.Package (LocalPackage (..), Package (..))+import qualified Stack.Types.Package as Stack+import Stack.Types.SourceMap (SourceMap (..))++localPackageToPackage :: LocalPackage -> Package+localPackageToPackage lp =+ fromMaybe (lpPackage lp) (lpTestBench lp)++{- | Resolve the direct (depth 0) external dependencies of the given local packages (assumed to come from project packages)++Stolen from @stack@ and further simplified.+-}+projectPackageDependencies ::+ [LocalPackage] -> [(Stack.PackageName, Set Stack.PackageName)]+projectPackageDependencies locals =+ map+ ( \lp ->+ let pkg = localPackageToPackage lp+ in (Stack.packageName pkg, deps pkg)+ )+ locals+ where+ deps pkg =+ Set.intersection localNames (packageAllDeps pkg)+ localNames = Set.fromList $ map (Stack.packageName . lpPackage) locals++buildPackageGraph :: PackageGraphOptions Stack -> IO PackageGraph+buildPackageGraph PackageGraphOptions {customOptions = StackOptions {..}, ..} = do+ withCurrentDir targetPath $ do+ let pInfo =+ Opt.info+ (globalOptsParser (fromAbsDir targetPath) OuterGlobalOpts <**> helper)+ mempty+ cliOpts =+ "--skip-ghc-check"+ : concat+ [ ["--test", "--no-run-tests"]+ | tests components+ ]+ <> concat+ [ ["--bench", "--no-run-benchmarks"]+ | benchmarks components+ ]+ ++ map T.unpack stackOptions+ Just gopt <-+ mapM (globalOptsFromMonoid False) $+ Opt.getParseResult $+ Opt.execParserPure (Opt.prefs mempty) pInfo cliOpts++ withRunnerGlobal gopt $+ withConfig NoReexec $+ withDefaultEnvConfig buildPackageGraphM++buildPackageGraphM ::+ (HasSourceMap env, HasBuildConfig env) =>+ RIO env PackageGraph+buildPackageGraphM = do+ sourceMap <- view sourceMapL+ locals <- mapM loadLocalPackage $ toList $ smProject sourceMap+ let gr = projectPackageDependencies locals+ pure $+ getOverlayed $+ foldMap+ ( \(fromStackPackageName -> pkg, deps) ->+ foldMap (Overlayed . G.edge pkg . fromStackPackageName) deps+ )+ gr++fromStackPackageName :: Stack.PackageName -> Guard.PackageName+fromStackPackageName = fromString . unPackageName
+ src/Development/Guardian/Graph/Adapter/Stack/Types.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}++module Development.Guardian.Graph.Adapter.Stack.Types (+ Stack,+ CustomPackageOptions (..),+) where++import Data.Aeson (FromJSON (parseJSON))+import qualified Data.Aeson as J+import Data.Text (Text)+import Development.Guardian.Graph.Adapter.Types+import GHC.Generics (Generic)++data Stack++newtype instance CustomPackageOptions Stack = StackOptions {stackOptions :: [Text]}+ deriving (Show, Eq, Ord, Generic)++instance FromJSON (CustomPackageOptions Stack) where+ parseJSON = J.withObject "{stack: }" $ \obj -> do+ stack <- obj J..:? "stack"+ case stack of+ Nothing -> pure $ StackOptions []+ Just dic -> StackOptions <$> dic J..:? "options" J..!= []
src/Development/Guardian/Graph/Adapter/Types.hs view
@@ -19,15 +19,13 @@ import GHC.Generics (Generic) import Path (Abs, Dir, Path) -data StandardAdapters = Stack | Cabal+data StandardAdapters = Stack | Cabal | Custom deriving (Show, Eq, Ord) data family CustomPackageOptions backend newtype PackageBuildParser backend = PackageBuildParser- { withTargetPath ::- Path Abs Dir ->- PackageGraphOptions backend+ { withTargetPath :: Path Abs Dir -> PackageGraphOptions backend } instance
src/Development/Guardian/Types.hs view
@@ -1,16 +1,20 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} module Development.Guardian.Types where import Algebra.Graph (Graph)+import qualified Algebra.Graph as G import Algebra.Graph.AdjacencyMap.Algorithm (Cycle) import qualified Algebra.Graph.Class as GC import Algebra.Graph.Label@@ -18,19 +22,36 @@ import Algebra.Graph.Relation.Preorder (PreorderRelation) import Control.Applicative import Control.Exception (Exception)+import Control.Monad import Control.Monad.Trans.Reader (ReaderT (ReaderT, runReaderT))+import Control.Monad.Trans.Writer.CPS (runWriter, tell) import Data.Aeson (FromJSON (..), FromJSONKey, genericParseJSON, withObject, withText, (.:), (.:?)) import qualified Data.Aeson as J+import qualified Data.Bifunctor as Bi import Data.Coerce (coerce)+import qualified Data.DList.DNonEmpty as DLNE+import Data.Foldable (fold)+import qualified Data.Foldable as F+import Data.Functor.Compose (Compose (..))+import Data.Generics.Labels () import qualified Data.HashMap.Strict as HM import Data.Hashable (Hashable)+import Data.List.NonEmpty (NonEmpty) import Data.Map (Map) import qualified Data.Map.Strict as Map+import Data.Maybe (isJust, mapMaybe)+import Data.Monoid (Last (..)) import Data.Set (Set)+import qualified Data.Set as Set import Data.String (IsString) import Data.Text (Text)+import qualified Data.Text.Encoding as T+import qualified Data.Trie as Trie import qualified Data.Vector as V import GHC.Generics (Generic)+import RIO ((^.))+import Text.Pattern (Pattern, concretePrefix)+import qualified Text.Pattern as P type DomainGraph = PreorderRelation DomainName @@ -80,6 +101,7 @@ , introducedBy :: [(PackageName, PackageName)] } | CyclicPackageDep (Cycle PackageName)+ | OrphanPackage PackageName [PackageName] | UncoveredPackages [PackageName] deriving (Show, Eq, Ord, Generic) deriving anyclass (Exception)@@ -92,13 +114,15 @@ deriving (Eq, Ord, Generic) deriving newtype (Show, IsString, FromJSON, FromJSONKey, Hashable) -data Domain = Domain+data Domain' a = Domain { dependsOn :: Maybe (V.Vector DomainName)- , packages :: V.Vector PackageDef+ , packages :: V.Vector (PackageDef' a) }- deriving (Show, Eq, Ord, Generic)+ deriving (Show, Eq, Ord, Generic, Functor, Foldable, Traversable) -instance FromJSON Domain where+type Domain = Domain' PackageName++instance FromJSON a => FromJSON (Domain' a) where parseJSON = genericParseJSON J.defaultOptions@@ -106,20 +130,84 @@ , J.fieldLabelModifier = J.camelTo2 '_' } -newtype Domains = Domains {domains :: HM.HashMap DomainName Domain}+type PackageDef = PackageDef' PackageName++newtype Domains = Domains+ { getDomains :: HM.HashMap DomainName Domain+ } deriving (Show, Eq, Ord, Generic)- deriving anyclass (FromJSON) -data PackageDef = PackageDef- { packageName :: !PackageName+data DomainsConfig+ = -- | Domain definition without wildcards+ ConcreteDomains Domains+ | -- | Domain definition containing wildcards+ WildcardDomains (HM.HashMap DomainName (Domain' Pattern))+ deriving (Show, Eq, Ord, Generic)++instance FromJSON DomainsConfig where+ parseJSON = withObject "{domains: ... [, wildcards: true]}" $ \obj -> do+ wildcards <- obj .:? "wildcards" J..!= False+ if wildcards+ then WildcardDomains <$> obj .: "domains"+ else ConcreteDomains . Domains <$> obj .: "domains"++data DomainResult = DomainResult {domains :: Domains, warnings :: Maybe (NonEmpty String)}+ deriving (Show, Eq, Ord, Generic)++{- |+Resolves patterns in packages in the domains.+If the multiple patterns matched, it picks one with the longest prefix.+-}+resolveDomainName :: DomainsConfig -> PackageGraph -> DomainResult+resolveDomainName (ConcreteDomains doms) _ = DomainResult doms Nothing+resolveDomainName (WildcardDomains patDoms) pkgGraph =+ let pkgs = G.vertexList pkgGraph+ pats =+ Trie.fromList $+ Map.toList $+ Map.fromListWith (<>) $+ map ((,) <$> T.encodeUtf8 . concretePrefix <*> Set.singleton) $+ F.toList $+ Compose patDoms+ pkgAssigns =+ fmap (V.fromList . Set.toList) $+ HM.fromList $+ Map.toList $+ Map.fromListWith (<>) $+ mapMaybe+ ( \pn@(PackageName nm) ->+ fmap (,Set.singleton pn)+ $ getLast+ $ foldMap+ (\(_, ps, _) -> Last $ F.find (isJust . (`P.match` nm)) ps)+ $ Trie.matches pats (T.encodeUtf8 nm)+ )+ pkgs+ (doms, warns) = Bi.second (fmap DLNE.toNonEmpty) $+ runWriter $+ forM patDoms $ \dom -> do+ pkgs' <- fmap fold $ V.forM (packages dom) $ \pkgDef -> do+ let aPat = pkgDef ^. #packageName+ cands = HM.lookupDefault mempty aPat pkgAssigns+ when (V.null cands) $+ tell $+ Just $+ DLNE.singleton $+ "No match found for pattern: " <> show aPat+ pure $ V.map (\pn -> pkgDef {packageName = pn}) cands+ pure dom {packages = pkgs'}+ in DomainResult {domains = Domains doms, warnings = warns}++data PackageDef' a = PackageDef+ { packageName :: !a , extraDeps :: V.Vector Dependency }- deriving (Show, Eq, Ord, Generic)+ deriving (Show, Eq, Ord, Generic, Functor, Foldable, Traversable) -instance FromJSON PackageDef where+instance FromJSON a => FromJSON (PackageDef' a) where parseJSON = runReaderT $- ReaderT (withText "package name" (pure . (`PackageDef` V.empty) . PackageName))+ ReaderT (fmap (`PackageDef` V.empty) . J.parseJSON) <|> ReaderT do withObject "object" $ \dic -> do packageName <- dic .: "package"@@ -140,8 +228,7 @@ ( withObject "{package: ...} or {domain: ...}" ( \obj ->- DomainDep <$> obj .: "domain"- <|> PackageDep <$> obj .: "package"+ DomainDep <$> obj .: "domain" <|> PackageDep <$> obj .: "package" ) )
+ src/Text/Pattern.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module Text.Pattern (+ Pattern (),+ concretePrefix,+ parsePattern,+ match,+ patternRE,+) where++import Data.Aeson (FromJSON (..))+import qualified Data.Aeson as J+import Data.Foldable (fold)+import qualified Data.Foldable as F+import Data.Functor.Compose (Compose (..))+import Data.Hashable (Hashable)+import Data.Maybe (fromMaybe, isJust)+import Data.Sequence (Seq (..))+import qualified Data.Sequence as Seq+import Data.String (IsString (..))+import Data.Text (Text)+import qualified Data.Text as T+import GHC.Generics (Generic)+import Text.Regex.Applicative.Text (RE', (<|>))+import qualified Text.Regex.Applicative.Text as RE++data Token = Literal !Text | Wildcard+ deriving (Show, Eq, Ord, Generic)+ deriving anyclass (Hashable)++newtype Pattern = Pattern {getTokens :: [Token]}+ deriving (Eq, Ord, Generic)+ deriving newtype (Hashable)++instance Show Pattern where+ showsPrec _ (Pattern toks) = foldl (.) id $ map go toks+ where+ go (Literal t) = showString $ T.unpack $ T.replace "*" "\\*" t+ go Wildcard = showChar '*'++-- >>> "hoo\\*bar" :: Pattern+-- /hoo\*bar/++concretePrefix :: Pattern -> Text+{-# INLINE concretePrefix #-}+concretePrefix =+ fold+ . Compose+ . takeWhile isJust+ . map (\case Literal t -> Just t; _ -> Nothing)+ . getTokens++instance IsString Pattern where+ fromString = fromMaybe (error "fromString(Pattern): parse failed!") . parsePattern . T.pack+ {-# INLINE fromString #-}++compilePattern :: Pattern -> RE' [Text]+{-# INLINE compilePattern #-}+compilePattern = traverse go . getTokens+ where+ go (Literal t) = RE.string t+ go Wildcard = textOf $ RE.many RE.anySym++textOf :: RE' a -> RE' Text+textOf = fmap snd . RE.withMatched++instance FromJSON Pattern where+ parseJSON = J.withText "pattern" $ \text ->+ maybe (fail $ "Invalid pattern: " <> show text) pure $+ parsePattern text+ {-# INLINE parseJSON #-}++{- |+Matches against the pattern.++>>> match "foo*bar" "foobar"+Just "foobar"++>>> match "foo.bar.*" "foo.bar.buz"+Just "foo.bar.buz"++>>> match "foo\\*bar" "foobar"+Nothing+-}+match :: Pattern -> Text -> Maybe Text+{-# INLINE match #-}+match = fmap (fmap mconcat) . RE.match . compilePattern++parsePattern :: Text -> Maybe Pattern+parsePattern = RE.match patternRE++patternRE :: RE' Pattern+patternRE =+ Pattern . F.toList+ <$> RE.reFoldl+ RE.Greedy+ ( \case+ Seq.Empty -> Seq.singleton+ ls@(_ :|> Wildcard) -> \case+ Wildcard -> ls+ r -> ls :|> r+ ls@(ls0 :|> Literal l) -> \case+ Literal r -> ls0 :|> Literal (l <> r)+ r -> ls :|> r+ )+ Seq.empty+ ( Literal <$> textOf (RE.many $ RE.psym (`notElem` ['\\', '*']))+ <|> Wildcard <$ RE.sym '*'+ <|> Literal . T.singleton <$ RE.sym '\\' <*> RE.anySym+ )
test/Development/Guardian/AppSpec.hs view
@@ -13,14 +13,18 @@ import qualified Data.Text.Lazy.Encoding as LT import Data.Version (showVersion) import Development.Guardian.App+import Development.Guardian.Flags (cabalEnabled, stackEnabled) import Development.Guardian.Graph.Adapter.Detection+import Development.Guardian.Test.Flags import GHC.IO.Exception (ExitCode (..)) import Path import Path.IO import Paths_guardian (version)-import RIO (logOptionsMemory, mkSimpleApp, readIORef, runRIO, withLogFunc)+import RIO (logOptionsMemory, mkSimpleApp, readIORef, runRIO, runSimpleApp, withLogFunc) import qualified RIO.ByteString.Lazy as LBS+import RIO.Process (proc, runProcess_) import Test.Tasty+import Test.Tasty.ExpectedFailure (ignoreTestBecause) import Test.Tasty.HUnit fakeBuildInfo :: BuildInfo@@ -29,65 +33,108 @@ test_defaultMainWith :: TestTree test_defaultMainWith = testGroup "defaultMainWith" $- concreteAdapterTests : stackCases ++ cabalCases ++ autoCases+ concreteAdapterTests : stackCases ++ cabalCases ++ autoCases ++ customCases -stackCases :: [TestTree]-stackCases =+customCases :: [TestTree]+customCases = [ testGroup- "stack-specific options"- [ testCase "Respects --stack-yaml"+ "custom adapter"+ [ testConditional "cabal-plan" testCabalPlan+ $ testCase "works with cabal-plan dot" $ withCurrentDir- ([reldir|data|] </> [reldir|test-only-dependency|])+ ([reldir|data|] </> [reldir|only-custom-cabal-plan|])+ $ do+ runSimpleApp $ proc "cabal" ["v2-update"] runProcess_+ runSimpleApp $ proc "cabal" ["v2-build", "--dry-run", "all"] runProcess_+ successfully_ $+ mainWith ["custom"]+ , testConditional "graphmod" testGraphmod $+ testCase "works with graphmod" $+ successfully_ $+ mainWith ["custom", "-c", "dependency-domains-graphmod.yaml"]+ , testCase "works with stack dot"+ $ withCurrentDir+ ([reldir|data|] </> [reldir|only-stack|]) $ successfully_- $ mainWith ["cabal", "-c", "dependency-domains-custom-stack.yaml"]+ $ mainWith ["custom", "-c", "dependency-domains-stack-dot.yaml"] ] ] +stackCases :: [TestTree]+stackCases =+ [ skipIfStackDisabled $+ testGroup+ "stack-specific options"+ [ testCase "Respects --stack-yaml"+ $ withCurrentDir+ ([reldir|data|] </> [reldir|test-only-dependency|])+ $ successfully_+ $ mainWith ["cabal", "-c", "dependency-domains-custom-stack.yaml"]+ ]+ ]+ cabalCases :: [TestTree] cabalCases =- [ testGroup- "cabal-specific options"- [ testCase "Respects projectFile"- $ withCurrentDir- ([reldir|data|] </> [reldir|test-only-dependency|])- $ successfully_- $ mainWith ["cabal", "-c", "dependency-domains-custom-cabal.yaml"]- , testCase "Respects update: true"- $ withCurrentDir- ([reldir|data|] </> [reldir|test-only-dependency|])- $ successfully_- $ mainWith ["cabal", "-c", "dependency-domains-cabal-update-true.yaml"]- , testCase "Respects update: (index-state)"- $ withCurrentDir- ([reldir|data|] </> [reldir|test-only-dependency|])- $ successfully_- $ mainWith ["cabal", "-c", "dependency-domains-cabal-update-index.yaml"]- ]+ [ skipIfCabalDisabled $+ testGroup+ "cabal-specific options"+ [ testCase "Respects projectFile"+ $ withCurrentDir+ ([reldir|data|] </> [reldir|test-only-dependency|])+ $ successfully_+ $ mainWith ["cabal", "-c", "dependency-domains-custom-cabal.yaml"]+ , testCase "Respects update: true"+ $ withCurrentDir+ ([reldir|data|] </> [reldir|test-only-dependency|])+ $ successfully_+ $ mainWith ["cabal", "-c", "dependency-domains-cabal-update-true.yaml"]+ , testCase "Respects update: (index-state)"+ $ withCurrentDir+ ([reldir|data|] </> [reldir|test-only-dependency|])+ $ successfully_+ $ mainWith ["cabal", "-c", "dependency-domains-cabal-update-index.yaml"]+ ] ] +skipIfCabalDisabled :: TestTree -> TestTree+skipIfCabalDisabled = testConditional "cabal" cabalEnabled++skipIfStackDisabled :: TestTree -> TestTree+skipIfStackDisabled = testConditional "stack" stackEnabled++testConditional :: String -> Bool -> TestTree -> TestTree+testConditional label testIt =+ if testIt+ then id+ else ignoreTestBecause $ "Test disabled for " <> label+ autoCases :: [TestTree] autoCases = [ testGroup "Auto detection"- [ testCase "Accepts config with cabal section only"+ [ skipIfCabalDisabled+ $ testCase "Accepts config with cabal section only" $ withCurrentDir ([reldir|data|] </> [reldir|test-only-dependency|]) $ successfully (LT.isInfixOf "with backend Cabal" . LT.decodeUtf8) $ mainWith ["auto", "-c", "dependency-domains-custom-cabal.yaml"]- , testCase "Accepts config with stack section only"+ , skipIfStackDisabled+ $ testCase "Accepts config with stack section only" $ withCurrentDir ([reldir|data|] </> [reldir|test-only-dependency|]) $ successfully (LT.isInfixOf "with backend Stack" . LT.decodeUtf8) $ mainWith ["auto", "-c", "dependency-domains-custom-stack.yaml"]- , testCase "Accepts unambiguous directory (cabal)"+ , skipIfCabalDisabled+ $ testCase "Accepts unambiguous directory (cabal)" $ withCurrentDir ([reldir|data|] </> [reldir|only-cabal|]) $ successfully (LT.isInfixOf "with backend Cabal" . LT.decodeUtf8) $ mainWith ["auto"]- , testCase "Accepts unambiguous directory (stack)"+ , skipIfStackDisabled+ $ testCase "Accepts unambiguous directory (stack)" $ withCurrentDir ([reldir|data|] </> [reldir|only-stack|]) $ successfully@@ -101,7 +148,7 @@ mainWith ["auto"] `shouldThrow` (== NoCustomConfigSpecified) step "Abmiguous Directory & Config wit both custom sections" mainWith ["auto", "-c", "dependency-domains-ambiguous.yaml"]- `shouldThrow` (== BothCabalAndStackSectionsPresentInConfigYaml)+ `shouldThrow` (== MultipleAdapterConfigFound) ] ] @@ -109,29 +156,33 @@ concreteAdapterTests = testGroup "Concrete adapter behaviours, independent of adapters"- [ testGroup- backend- [ testCase "invalidates test-only-dependency with default config"- $ withCurrentDir- ([reldir|data|] </> [reldir|test-only-dependency|])- $ mainWith [backend] `shouldThrow` (== ExitFailure 1)- , testCaseSteps "invalidates test-only-dependency with default config (explicit path argument)" \step -> do- step "Absolute dir"- dir <- canonicalizePath ([reldir|data|] </> [reldir|test-only-dependency|])- mainWith [backend, fromAbsDir dir] `shouldThrow` (== ExitFailure 1)- step "Relative dir"- let rdir = [reldir|data|] </> [reldir|test-only-dependency|]- mainWith [backend, fromRelDir rdir] `shouldThrow` (== ExitFailure 1)- , testCaseSteps "accepts non-standard config yaml" $ \step ->- withCurrentDir ([reldir|data|] </> [reldir|test-only-dependency|]) $ do- step "Accepts when tests and benchmarks disabled"- successfully_ $- mainWith [backend, "-c", "dependency-domains-no-tests-benchmarks.yaml"]- step "Accepts input with exception rule"- successfully (LT.isInfixOf "exceptional rules are used" . LT.decodeUtf8) $- mainWith [backend, "-c", "dependency-domains-except-A2-B1.yaml"]- ]- | backend <- ["cabal", "stack"]+ [ skipIfDisabled $+ testGroup+ backend+ [ testCase "invalidates test-only-dependency with default config"+ $ withCurrentDir+ ([reldir|data|] </> [reldir|test-only-dependency|])+ $ mainWith [backend] `shouldThrow` (== ExitFailure 1)+ , testCaseSteps "invalidates test-only-dependency with default config (explicit path argument)" \step -> do+ step "Absolute dir"+ dir <- canonicalizePath ([reldir|data|] </> [reldir|test-only-dependency|])+ mainWith [backend, fromAbsDir dir] `shouldThrow` (== ExitFailure 1)+ step "Relative dir"+ let rdir = [reldir|data|] </> [reldir|test-only-dependency|]+ mainWith [backend, fromRelDir rdir] `shouldThrow` (== ExitFailure 1)+ , testCaseSteps "accepts non-standard config yaml" $ \step ->+ withCurrentDir ([reldir|data|] </> [reldir|test-only-dependency|]) $ do+ step "Accepts when tests and benchmarks disabled"+ successfully_ $+ mainWith [backend, "-c", "dependency-domains-no-tests-benchmarks.yaml"]+ step "Accepts input with exception rule"+ successfully (LT.isInfixOf "exceptional rules are used" . LT.decodeUtf8) $+ mainWith [backend, "-c", "dependency-domains-except-A2-B1.yaml"]+ ]+ | (backend, skipIfDisabled) <-+ [ ("cabal", skipIfCabalDisabled)+ , ("stack", skipIfStackDisabled)+ ] ] successfully_ :: HasCallStack => IO (LBS.ByteString, Maybe SomeException) -> IO ()
+ test/Development/Guardian/Test/Flags.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE CPP #-}++module Development.Guardian.Test.Flags (testGraphmod, testCabalPlan) where++testGraphmod :: Bool+#if defined(TEST_GRAPHMOD)+testGraphmod = True+#else+testGraphmod = False+#endif++testCabalPlan :: Bool+#if defined(TEST_CABAL_PLAN)+testCabalPlan = True+#else+testCabalPlan = False+#endif