{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Development.Guardian.Graph where

import qualified Algebra.Graph as G
import qualified Algebra.Graph.Class as GC
import Algebra.Graph.Label (Path)
import qualified Algebra.Graph.Labelled as LG
import qualified Algebra.Graph.Relation as Rel
import qualified Algebra.Graph.Relation.Preorder as Preorder
import qualified Algebra.Graph.ToGraph as GC
import Control.Monad (guard, void)
import Data.Bifunctor (Bifunctor)
import qualified Data.Bifunctor as Bi
import Data.Coerce (coerce)
import qualified Data.DList as DL
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.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 GHC.Generics (Generic)
import Validation

buildDomainInfo :: Domains -> Validation (NE.NonEmpty DomainGraphError) DomainInfo
buildDomainInfo :: Domains -> Validation (NonEmpty DomainGraphError) DomainInfo
buildDomainInfo Domains
domainConfig = do
  let packageDic :: PackageDic
packageDic = Domains -> PackageDic
buildPackageDic Domains
domainConfig
  DomainGraph
domainGraph <- Domains -> Validation (NonEmpty DomainGraphError) DomainGraph
toDomainGraph Domains
domainConfig
  pure DomainInfo {PackageDic
DomainGraph
Domains
packageDic :: PackageDic
domainGraph :: DomainGraph
domainConfig :: Domains
domainGraph :: DomainGraph
packageDic :: PackageDic
domainConfig :: Domains
..}

buildRawDomainGraph ::
  (GC.Graph gr, GC.Vertex gr ~ DomainName) =>
  Domains ->
  gr
buildRawDomainGraph :: forall gr. (Graph gr, Vertex gr ~ DomainName) => Domains -> gr
buildRawDomainGraph Domains {HashMap DomainName Domain
domains :: Domains -> HashMap DomainName Domain
domains :: HashMap DomainName Domain
..} =
  forall gr. Overlayed gr -> gr
getOverlayed forall a b. (a -> b) -> a -> b
$
    forall m k v. Monoid m => (k -> v -> m) -> HashMap k v -> m
HM.foldMapWithKey
      ( \DomainName
dom Domain {Maybe (Vector DomainName)
Vector PackageDef
packages :: Vector PackageDef
dependsOn :: Maybe (Vector DomainName)
packages :: Domain -> Vector PackageDef
dependsOn :: Domain -> Maybe (Vector DomainName)
..} ->
          forall gr. gr -> Overlayed gr
Overlayed (forall g. Graph g => Vertex g -> g
GC.vertex DomainName
dom)
            forall a. Semigroup a => a -> a -> a
<> forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall gr. gr -> Overlayed gr
Overlayed forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall g. Graph g => Vertex g -> Vertex g -> g
GC.edge DomainName
dom)) Maybe (Vector DomainName)
dependsOn
      )
      HashMap DomainName Domain
domains

toDomainGraph :: Domains -> Validation (NE.NonEmpty DomainGraphError) DomainGraph
toDomainGraph :: Domains -> Validation (NonEmpty DomainGraphError) DomainGraph
toDomainGraph Domains
doms =
  forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
Bi.first forall a. DNonEmpty a -> NonEmpty a
DLNE.toNonEmpty forall a b. (a -> b) -> a -> b
$
    DomainGraph
ans
      forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
Bi.first forall a. a -> DNonEmpty a
DLNE.singleton (forall t.
(ToGraph t, Ord (ToVertex t), ToVertex t ~ DomainName) =>
t -> Validation DomainGraphError ()
detectCycle Relation DomainName
raw)
      forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
Bi.first forall a. a -> DNonEmpty a
DLNE.singleton (Domains -> Validation DomainGraphError ()
detectPackageOverlaps Domains
doms)
  where
    !raw :: Relation DomainName
raw = forall gr. (Graph gr, Vertex gr ~ DomainName) => Domains -> gr
buildRawDomainGraph Domains
doms
    !ans :: DomainGraph
ans = forall a. Relation a -> PreorderRelation a
Preorder.fromRelation Relation DomainName
raw

detectPackageOverlaps ::
  Domains -> Validation DomainGraphError ()
detectPackageOverlaps :: Domains -> Validation DomainGraphError ()
detectPackageOverlaps Domains {HashMap DomainName Domain
domains :: HashMap DomainName Domain
domains :: Domains -> HashMap DomainName Domain
..}
  | forall k a. Map k a -> Bool
Map.null Map PackageName (Set DomainName)
overlaps = forall e a. a -> Validation e a
Success ()
  | Bool
otherwise = forall e a. e -> Validation e a
Failure forall a b. (a -> b) -> a -> b
$ Map PackageName (Set DomainName) -> DomainGraphError
OverlappingPackages Map PackageName (Set DomainName)
overlaps
  where
    overlaps :: Map PackageName (Set DomainName)
overlaps =
      forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter ((forall a. Ord a => a -> a -> Bool
> Int
1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> Int
Set.size) forall a b. (a -> b) -> a -> b
$
        forall k v. CatMap k v -> Map k v
getCatMap forall a b. (a -> b) -> a -> b
$
          forall m k v. Monoid m => (k -> v -> m) -> HashMap k v -> m
HM.foldMapWithKey
            ( \DomainName
dom ->
                forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
                  ( forall k v. Map k v -> CatMap k v
CatMap
                      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall k a. k -> a -> Map k a
Map.singleton (forall a. a -> Set a
Set.singleton DomainName
dom)
                      forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageDef -> PackageName
packageName
                  )
                  forall b c a. (b -> c) -> (a -> b) -> a -> c
. Domain -> Vector PackageDef
packages
            )
            HashMap DomainName Domain
domains

newtype CatMap k v = CatMap {forall k v. CatMap k v -> Map k v
getCatMap :: Map k v}

instance (Semigroup v, Ord k) => Semigroup (CatMap k v) where
  <> :: CatMap k v -> CatMap k v -> CatMap k v
(<>) = coerce :: forall a b. Coercible a b => a -> b
coerce forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith @k @v forall a. Semigroup a => a -> a -> a
(<>)
  {-# INLINE (<>) #-}

instance (Semigroup v, Ord k) => Monoid (CatMap k v) where
  mempty :: CatMap k v
mempty = forall k v. Map k v -> CatMap k v
CatMap forall k a. Map k a
Map.empty
  {-# INLINE mempty #-}

detectCycle ::
  (GC.ToGraph t, Ord (GC.ToVertex t), GC.ToVertex t ~ DomainName) =>
  t ->
  Validation DomainGraphError ()
detectCycle :: forall t.
(ToGraph t, Ord (ToVertex t), ToVertex t ~ DomainName) =>
t -> Validation DomainGraphError ()
detectCycle t
gr =
  forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
Bi.first Cycle DomainName -> DomainGraphError
CyclicDomainDep forall a b. (a -> b) -> a -> b
$
    forall e a. Either e a -> Validation e a
eitherToValidation forall a b. (a -> b) -> a -> b
$
      forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$
        forall t.
(ToGraph t, Ord (ToVertex t)) =>
t -> Either (Cycle (ToVertex t)) [ToVertex t]
GC.topSort t
gr

buildPackageDic :: Domains -> PackageDic
buildPackageDic :: Domains -> PackageDic
buildPackageDic =
  forall m k v. Monoid m => (k -> v -> m) -> HashMap k v -> m
HM.foldMapWithKey
    ( \DomainName
domName Domain {Maybe (Vector DomainName)
Vector PackageDef
packages :: Vector PackageDef
dependsOn :: Maybe (Vector DomainName)
packages :: Domain -> Vector PackageDef
dependsOn :: Domain -> Maybe (Vector DomainName)
..} ->
        forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$
          forall a b. (a -> b) -> [a] -> [b]
map (\PackageDef {Vector Dependency
PackageName
extraDeps :: Vector Dependency
packageName :: PackageName
packageName :: PackageDef -> PackageName
extraDeps :: PackageDef -> Vector Dependency
..} -> (PackageName
packageName, (DomainName
domName, Vector Dependency
extraDeps))) forall a b. (a -> b) -> a -> b
$
            forall a. Vector a -> [a]
V.toList Vector PackageDef
packages
    )
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. Domains -> HashMap DomainName Domain
domains

matches :: PackageDic -> Dependency -> PackageName -> Bool
matches :: PackageDic -> Dependency -> PackageName -> Bool
matches PackageDic
pkgDic (DomainDep DomainName
dn) PackageName
pkg =
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False ((DomainName
dn forall a. Eq a => a -> a -> Bool
==) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
pkg PackageDic
pkgDic
matches PackageDic
_ (PackageDep PackageName
pn) PackageName
pkg = PackageName
pn forall a. Eq a => a -> a -> Bool
== PackageName
pkg

newtype LOverlayed e a = LOverlayed {forall e a. LOverlayed e a -> Graph e a
getLOverlayed :: LG.Graph e a}
  deriving (Int -> LOverlayed e a -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
forall e a. (Show a, Show e) => Int -> LOverlayed e a -> ShowS
forall e a. (Show a, Show e) => [LOverlayed e a] -> ShowS
forall e a. (Show a, Show e) => LOverlayed e a -> [Char]
showList :: [LOverlayed e a] -> ShowS
$cshowList :: forall e a. (Show a, Show e) => [LOverlayed e a] -> ShowS
show :: LOverlayed e a -> [Char]
$cshow :: forall e a. (Show a, Show e) => LOverlayed e a -> [Char]
showsPrec :: Int -> LOverlayed e a -> ShowS
$cshowsPrec :: forall e a. (Show a, Show e) => Int -> LOverlayed e a -> ShowS
Show, LOverlayed e a -> LOverlayed e a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall e a.
(Monoid e, Ord a, Eq e) =>
LOverlayed e a -> LOverlayed e a -> Bool
/= :: LOverlayed e a -> LOverlayed e a -> Bool
$c/= :: forall e a.
(Monoid e, Ord a, Eq e) =>
LOverlayed e a -> LOverlayed e a -> Bool
== :: LOverlayed e a -> LOverlayed e a -> Bool
$c== :: forall e a.
(Monoid e, Ord a, Eq e) =>
LOverlayed e a -> LOverlayed e a -> Bool
Eq, LOverlayed e a -> LOverlayed e a -> Bool
LOverlayed e a -> LOverlayed e a -> Ordering
LOverlayed e a -> LOverlayed e a -> LOverlayed e a
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {e} {a}. (Monoid e, Ord a, Ord e) => Eq (LOverlayed e a)
forall e a.
(Monoid e, Ord a, Ord e) =>
LOverlayed e a -> LOverlayed e a -> Bool
forall e a.
(Monoid e, Ord a, Ord e) =>
LOverlayed e a -> LOverlayed e a -> Ordering
forall e a.
(Monoid e, Ord a, Ord e) =>
LOverlayed e a -> LOverlayed e a -> LOverlayed e a
min :: LOverlayed e a -> LOverlayed e a -> LOverlayed e a
$cmin :: forall e a.
(Monoid e, Ord a, Ord e) =>
LOverlayed e a -> LOverlayed e a -> LOverlayed e a
max :: LOverlayed e a -> LOverlayed e a -> LOverlayed e a
$cmax :: forall e a.
(Monoid e, Ord a, Ord e) =>
LOverlayed e a -> LOverlayed e a -> LOverlayed e a
>= :: LOverlayed e a -> LOverlayed e a -> Bool
$c>= :: forall e a.
(Monoid e, Ord a, Ord e) =>
LOverlayed e a -> LOverlayed e a -> Bool
> :: LOverlayed e a -> LOverlayed e a -> Bool
$c> :: forall e a.
(Monoid e, Ord a, Ord e) =>
LOverlayed e a -> LOverlayed e a -> Bool
<= :: LOverlayed e a -> LOverlayed e a -> Bool
$c<= :: forall e a.
(Monoid e, Ord a, Ord e) =>
LOverlayed e a -> LOverlayed e a -> Bool
< :: LOverlayed e a -> LOverlayed e a -> Bool
$c< :: forall e a.
(Monoid e, Ord a, Ord e) =>
LOverlayed e a -> LOverlayed e a -> Bool
compare :: LOverlayed e a -> LOverlayed e a -> Ordering
$ccompare :: forall e a.
(Monoid e, Ord a, Ord e) =>
LOverlayed e a -> LOverlayed e a -> Ordering
Ord, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall e a x. Rep (LOverlayed e a) x -> LOverlayed e a
forall e a x. LOverlayed e a -> Rep (LOverlayed e a) x
$cto :: forall e a x. Rep (LOverlayed e a) x -> LOverlayed e a
$cfrom :: forall e a x. LOverlayed e a -> Rep (LOverlayed e a) x
Generic)

instance Monoid e => Semigroup (LOverlayed e a) where
  <> :: LOverlayed e a -> LOverlayed e a -> LOverlayed e a
(<>) = coerce :: forall a b. Coercible a b => a -> b
coerce forall a b. (a -> b) -> a -> b
$ forall e a. Monoid e => Graph e a -> Graph e a -> Graph e a
LG.overlay @e @a
  {-# INLINE (<>) #-}

instance Monoid e => Monoid (LOverlayed e a) where
  mempty :: LOverlayed e a
mempty = forall e a. Graph e a -> LOverlayed e a
LOverlayed forall e a. Graph e a
LG.empty
  {-# INLINE mempty #-}

data ActualGraphs a b = AGs {forall a b. ActualGraphs a b -> a
activatedGraph :: a, forall a b. ActualGraphs a b -> b
exceptionGraph :: b}
  deriving (forall a b. a -> ActualGraphs a b -> ActualGraphs a a
forall a b. (a -> b) -> ActualGraphs a a -> ActualGraphs a b
forall a a b. a -> ActualGraphs a b -> ActualGraphs a a
forall a a b. (a -> b) -> ActualGraphs a a -> ActualGraphs a b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> ActualGraphs a b -> ActualGraphs a a
$c<$ :: forall a a b. a -> ActualGraphs a b -> ActualGraphs a a
fmap :: forall a b. (a -> b) -> ActualGraphs a a -> ActualGraphs a b
$cfmap :: forall a a b. (a -> b) -> ActualGraphs a a -> ActualGraphs a b
Functor, Int -> ActualGraphs a b -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
forall a b. (Show a, Show b) => Int -> ActualGraphs a b -> ShowS
forall a b. (Show a, Show b) => [ActualGraphs a b] -> ShowS
forall a b. (Show a, Show b) => ActualGraphs a b -> [Char]
showList :: [ActualGraphs a b] -> ShowS
$cshowList :: forall a b. (Show a, Show b) => [ActualGraphs a b] -> ShowS
show :: ActualGraphs a b -> [Char]
$cshow :: forall a b. (Show a, Show b) => ActualGraphs a b -> [Char]
showsPrec :: Int -> ActualGraphs a b -> ShowS
$cshowsPrec :: forall a b. (Show a, Show b) => Int -> ActualGraphs a b -> ShowS
Show, ActualGraphs a b -> ActualGraphs a b -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall a b.
(Eq a, Eq b) =>
ActualGraphs a b -> ActualGraphs a b -> Bool
/= :: ActualGraphs a b -> ActualGraphs a b -> Bool
$c/= :: forall a b.
(Eq a, Eq b) =>
ActualGraphs a b -> ActualGraphs a b -> Bool
== :: ActualGraphs a b -> ActualGraphs a b -> Bool
$c== :: forall a b.
(Eq a, Eq b) =>
ActualGraphs a b -> ActualGraphs a b -> Bool
Eq, ActualGraphs a b -> ActualGraphs a b -> Bool
ActualGraphs a b -> ActualGraphs a b -> Ordering
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {a} {b}. (Ord a, Ord b) => Eq (ActualGraphs a b)
forall a b.
(Ord a, Ord b) =>
ActualGraphs a b -> ActualGraphs a b -> Bool
forall a b.
(Ord a, Ord b) =>
ActualGraphs a b -> ActualGraphs a b -> Ordering
forall a b.
(Ord a, Ord b) =>
ActualGraphs a b -> ActualGraphs a b -> ActualGraphs a b
min :: ActualGraphs a b -> ActualGraphs a b -> ActualGraphs a b
$cmin :: forall a b.
(Ord a, Ord b) =>
ActualGraphs a b -> ActualGraphs a b -> ActualGraphs a b
max :: ActualGraphs a b -> ActualGraphs a b -> ActualGraphs a b
$cmax :: forall a b.
(Ord a, Ord b) =>
ActualGraphs a b -> ActualGraphs a b -> ActualGraphs a b
>= :: ActualGraphs a b -> ActualGraphs a b -> Bool
$c>= :: forall a b.
(Ord a, Ord b) =>
ActualGraphs a b -> ActualGraphs a b -> Bool
> :: ActualGraphs a b -> ActualGraphs a b -> Bool
$c> :: forall a b.
(Ord a, Ord b) =>
ActualGraphs a b -> ActualGraphs a b -> Bool
<= :: ActualGraphs a b -> ActualGraphs a b -> Bool
$c<= :: forall a b.
(Ord a, Ord b) =>
ActualGraphs a b -> ActualGraphs a b -> Bool
< :: ActualGraphs a b -> ActualGraphs a b -> Bool
$c< :: forall a b.
(Ord a, Ord b) =>
ActualGraphs a b -> ActualGraphs a b -> Bool
compare :: ActualGraphs a b -> ActualGraphs a b -> Ordering
$ccompare :: forall a b.
(Ord a, Ord b) =>
ActualGraphs a b -> ActualGraphs a b -> Ordering
Ord, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a b x. Rep (ActualGraphs a b) x -> ActualGraphs a b
forall a b x. ActualGraphs a b -> Rep (ActualGraphs a b) x
$cto :: forall a b x. Rep (ActualGraphs a b) x -> ActualGraphs a b
$cfrom :: forall a b x. ActualGraphs a b -> Rep (ActualGraphs a b) x
Generic)
  deriving (NonEmpty (ActualGraphs a b) -> ActualGraphs a b
ActualGraphs a b -> ActualGraphs a b -> ActualGraphs a b
forall b. Integral b => b -> ActualGraphs a b -> ActualGraphs a b
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
forall a b.
(Semigroup a, Semigroup b) =>
NonEmpty (ActualGraphs a b) -> ActualGraphs a b
forall a b.
(Semigroup a, Semigroup b) =>
ActualGraphs a b -> ActualGraphs a b -> ActualGraphs a b
forall a b b.
(Semigroup a, Semigroup b, Integral b) =>
b -> ActualGraphs a b -> ActualGraphs a b
stimes :: forall b. Integral b => b -> ActualGraphs a b -> ActualGraphs a b
$cstimes :: forall a b b.
(Semigroup a, Semigroup b, Integral b) =>
b -> ActualGraphs a b -> ActualGraphs a b
sconcat :: NonEmpty (ActualGraphs a b) -> ActualGraphs a b
$csconcat :: forall a b.
(Semigroup a, Semigroup b) =>
NonEmpty (ActualGraphs a b) -> ActualGraphs a b
<> :: ActualGraphs a b -> ActualGraphs a b -> ActualGraphs a b
$c<> :: forall a b.
(Semigroup a, Semigroup b) =>
ActualGraphs a b -> ActualGraphs a b -> ActualGraphs a b
Semigroup, ActualGraphs a b
[ActualGraphs a b] -> ActualGraphs a b
ActualGraphs a b -> ActualGraphs a b -> ActualGraphs a b
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall {a} {b}.
(Monoid a, Monoid b) =>
Semigroup (ActualGraphs a b)
forall a b. (Monoid a, Monoid b) => ActualGraphs a b
forall a b.
(Monoid a, Monoid b) =>
[ActualGraphs a b] -> ActualGraphs a b
forall a b.
(Monoid a, Monoid b) =>
ActualGraphs a b -> ActualGraphs a b -> ActualGraphs a b
mconcat :: [ActualGraphs a b] -> ActualGraphs a b
$cmconcat :: forall a b.
(Monoid a, Monoid b) =>
[ActualGraphs a b] -> ActualGraphs a b
mappend :: ActualGraphs a b -> ActualGraphs a b -> ActualGraphs a b
$cmappend :: forall a b.
(Monoid a, Monoid b) =>
ActualGraphs a b -> ActualGraphs a b -> ActualGraphs a b
mempty :: ActualGraphs a b
$cmempty :: forall a b. (Monoid a, Monoid b) => ActualGraphs a b
Monoid) via GenericSemigroupMonoid (ActualGraphs a b)

instance Bifunctor ActualGraphs where
  bimap :: forall a b c d.
(a -> b) -> (c -> d) -> ActualGraphs a c -> ActualGraphs b d
bimap a -> b
f c -> d
g (AGs a
x c
y) = forall a b. a -> b -> ActualGraphs a b
AGs (a -> b
f a
x) (c -> d
g c
y)
  {-# INLINE bimap #-}
  first :: forall a b c. (a -> b) -> ActualGraphs a c -> ActualGraphs b c
first a -> b
f (AGs a
x c
y) = forall a b. a -> b -> ActualGraphs a b
AGs (a -> b
f a
x) c
y
  {-# INLINE first #-}
  second :: forall b c a. (b -> c) -> ActualGraphs a b -> ActualGraphs a c
second b -> c
g (AGs a
x b
y) = forall a b. a -> b -> ActualGraphs a b
AGs a
x (b -> c
g b
y)
  {-# INLINE second #-}

buildActualGraphs ::
  PackageDic ->
  PackageGraph ->
  ActualGraphs ActualGraph (Map PackageName (Set Dependency))
buildActualGraphs :: PackageDic
-> PackageGraph
-> ActualGraphs ActualGraph (Map PackageName (Set Dependency))
buildActualGraphs PackageDic
pkgDic =
  forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
Bi.bimap
    (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
Bi.first forall a. DList a -> [a]
DL.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. LOverlayed e a -> Graph e a
getLOverlayed)
    (forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> Bool
Set.null) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k v. CatMap k v -> Map k v
getCatMap)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
      ( \e :: (PackageName, PackageName)
e@(PackageName
src, PackageName
dst) ->
          let (DomainName
srcDomain, Vector Dependency
srcExcept) =
                forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"src, not found: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show (PackageName
src, PackageDic
pkgDic)) forall a b. (a -> b) -> a -> b
$
                  forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
src PackageDic
pkgDic
              (DomainName
dstDomain, Vector Dependency
_) =
                forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"dst, not found: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show (PackageName
dst, PackageDic
pkgDic)) forall a b. (a -> b) -> a -> b
$
                  forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
dst PackageDic
pkgDic
              aGraph :: LOverlayed (DList (PackageName, PackageName)) DomainName
aGraph = forall e a. Graph e a -> LOverlayed e a
LOverlayed forall a b. (a -> b) -> a -> b
$ forall e a. e -> a -> a -> Graph e a
LG.edge (forall a. a -> DList a
DL.singleton (PackageName, PackageName)
e) DomainName
srcDomain DomainName
dstDomain
              excepts :: Set Dependency
excepts = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall a. Vector a -> [a]
V.toList forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> Vector a -> Vector a
V.filter (forall a b c. (a -> b -> c) -> b -> a -> c
flip (PackageDic -> Dependency -> PackageName -> Bool
matches PackageDic
pkgDic) PackageName
dst) Vector Dependency
srcExcept
           in if forall a. Set a -> Bool
Set.null Set Dependency
excepts
                then AGs {exceptionGraph :: CatMap PackageName (Set Dependency)
exceptionGraph = forall a. Monoid a => a
mempty, activatedGraph :: LOverlayed (DList (PackageName, PackageName)) DomainName
activatedGraph = LOverlayed (DList (PackageName, PackageName)) DomainName
aGraph}
                else AGs {activatedGraph :: LOverlayed (DList (PackageName, PackageName)) DomainName
activatedGraph = forall a. Monoid a => a
mempty, exceptionGraph :: CatMap PackageName (Set Dependency)
exceptionGraph = forall k v. Map k v -> CatMap k v
CatMap forall a b. (a -> b) -> a -> b
$ forall k a. k -> a -> Map k a
Map.singleton PackageName
src Set Dependency
excepts}
      )
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => Graph a -> [(a, a)]
G.edgeList

validatePackageGraph ::
  DomainInfo -> PackageGraph -> Validation (NE.NonEmpty PackageViolation) CheckResult
validatePackageGraph :: DomainInfo
-> PackageGraph
-> Validation (NonEmpty PackageViolation) CheckResult
validatePackageGraph DomainInfo {PackageDic
DomainGraph
Domains
packageDic :: PackageDic
domainGraph :: DomainGraph
domainConfig :: Domains
packageDic :: DomainInfo -> PackageDic
domainGraph :: DomainInfo -> DomainGraph
domainConfig :: DomainInfo -> Domains
..} PackageGraph
pg =
  forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
Bi.first forall a. DNonEmpty a -> NonEmpty a
DLNE.toNonEmpty forall a b. (a -> b) -> a -> b
$
    CheckResult
resl
      forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ( case forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
Bi.first forall a. a -> DNonEmpty a
DLNE.singleton (PackageGraph -> Validation PackageViolation ()
detectPackageCycle PackageGraph
pg) of
            f :: Validation (DNonEmpty PackageViolation) ()
f@Failure {} -> Validation (DNonEmpty PackageViolation) ()
f
            Success {} ->
              forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
Bi.first forall a. a -> DNonEmpty a
DLNE.singleton (PackageDic -> PackageGraph -> Validation PackageViolation ()
coversAllPackages PackageDic
packageDic PackageGraph
pg)
                forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* DomainGraph
-> ActualGraph -> Validation (DNonEmpty PackageViolation) ()
satisfiesDomainGraph DomainGraph
domainGraph ActualGraph
activatedGraph
         )
  where
    AGs {Map PackageName (Set Dependency)
ActualGraph
exceptionGraph :: Map PackageName (Set Dependency)
activatedGraph :: ActualGraph
exceptionGraph :: forall a b. ActualGraphs a b -> b
activatedGraph :: forall a b. ActualGraphs a b -> a
..} = PackageDic
-> PackageGraph
-> ActualGraphs ActualGraph (Map PackageName (Set Dependency))
buildActualGraphs PackageDic
packageDic PackageGraph
pg
    redundantExtras :: Map PackageName (Vector Dependency)
redundantExtras = PackageDic -> PackageGraph -> Map PackageName (Vector Dependency)
findRedundantExtraDeps PackageDic
packageDic PackageGraph
pg
    diags :: Diagnostics
diags =
      Diagnostics
        { redundantExtraDeps :: Map PackageName (Set Dependency)
redundantExtraDeps =
            forall a. Ord a => [a] -> Set a
Set.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Vector a -> [a]
V.toList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map PackageName (Vector Dependency)
redundantExtras
        , usedExceptionalRules :: Map PackageName (Set Dependency)
usedExceptionalRules = Map PackageName (Set Dependency)
exceptionGraph
        }
    resl :: CheckResult
resl
      | Diagnostics -> Bool
isEmptyDiagnostics Diagnostics
diags = CheckResult
Ok
      | Bool
otherwise = Diagnostics -> CheckResult
OkWithDiagnostics Diagnostics
diags

detectPackageCycle ::
  PackageGraph -> Validation PackageViolation ()
detectPackageCycle :: PackageGraph -> Validation PackageViolation ()
detectPackageCycle PackageGraph
pkgs =
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$
    forall e a. Either e a -> Validation e a
eitherToValidation forall a b. (a -> b) -> a -> b
$
      forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
Bi.first Cycle PackageName -> PackageViolation
CyclicPackageDep forall a b. (a -> b) -> a -> b
$
        forall t.
(ToGraph t, Ord (ToVertex t)) =>
t -> Either (Cycle (ToVertex t)) [ToVertex t]
GC.topSort PackageGraph
pkgs

type ExemptDomDeps = ActualGraph

findRedundantExtraDeps ::
  PackageDic ->
  PackageGraph ->
  Map PackageName (V.Vector Dependency)
findRedundantExtraDeps :: PackageDic -> PackageGraph -> Map PackageName (Vector Dependency)
findRedundantExtraDeps PackageDic
pkgDic PackageGraph
pg =
  forall k a b. (k -> a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybeWithKey
    ( \PackageName
pkg (DomainName
_, Vector Dependency
specifiedDeps) -> do
        let actualDepPkgs :: Set (ToVertex PackageGraph)
actualDepPkgs = forall t.
(ToGraph t, Ord (ToVertex t)) =>
ToVertex t -> t -> Set (ToVertex t)
GC.postSet PackageName
pkg PackageGraph
pg
            actualDepDoms :: Set DomainName
actualDepDoms =
              forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map
                (\PackageName
dpkg -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"No pkg find: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show (PackageName
dpkg, Set (ToVertex PackageGraph)
actualDepPkgs)) forall a b. (a, b) -> a
fst (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
dpkg PackageDic
pkgDic))
                Set (ToVertex PackageGraph)
actualDepPkgs
            deps :: Vector Dependency
deps =
              forall a. (a -> Bool) -> Vector a -> Vector a
V.filter
                ( \case
                    DomainDep DomainName
dn -> DomainName
dn forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set DomainName
actualDepDoms
                    PackageDep PackageName
pn -> PackageName
pn forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set (ToVertex PackageGraph)
actualDepPkgs
                )
                Vector Dependency
specifiedDeps
        forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall a. Vector a -> Bool
V.null Vector Dependency
deps
        pure Vector Dependency
deps
    )
    PackageDic
pkgDic

coversAllPackages ::
  PackageDic -> PackageGraph -> Validation PackageViolation ()
coversAllPackages :: PackageDic -> PackageGraph -> Validation PackageViolation ()
coversAllPackages PackageDic
pkgDic PackageGraph
pg =
  if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PackageName]
remain
    then forall e a. a -> Validation e a
Success ()
    else forall e a. e -> Validation e a
Failure forall a b. (a -> b) -> a -> b
$ [PackageName] -> PackageViolation
UncoveredPackages [PackageName]
remain
  where
    remain :: [PackageName]
remain = forall a. Set a -> [a]
Set.toList forall a b. (a -> b) -> a -> b
$ forall a. Ord a => Graph a -> Set a
G.vertexSet PackageGraph
pg forall a. Ord a => Set a -> Set a -> Set a
Set.\\ forall k a. Map k a -> Set k
Map.keysSet PackageDic
pkgDic

satisfiesDomainGraph ::
  DomainGraph -> ActualGraph -> Validation (DLNE.DNonEmpty PackageViolation) ()
satisfiesDomainGraph :: DomainGraph
-> ActualGraph -> Validation (DNonEmpty PackageViolation) ()
satisfiesDomainGraph DomainGraph
domGr ActualGraph
ag =
  forall a e. a -> Maybe e -> Validation e a
maybeToFailure () (forall a. NonEmpty a -> DNonEmpty a
DLNE.fromNonEmpty forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [PackageViolation]
violatingEdges)
  where
    expectedEdges :: Set (DomainName, DomainName)
expectedEdges = forall a. Relation a -> Set (a, a)
Rel.edgeSet forall a b. (a -> b) -> a -> b
$ forall a. Ord a => PreorderRelation a -> Relation a
Preorder.toRelation DomainGraph
domGr
    actualEdges :: Map (DomainName, DomainName) (Path PackageName)
    actualEdges :: Map (DomainName, DomainName) (Path PackageName)
actualEdges =
      forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$
        forall a b. (a -> b) -> [a] -> [b]
map (\(Path PackageName
x1, DomainName
dn, DomainName
dn') -> ((DomainName
dn, DomainName
dn'), Path PackageName
x1)) forall a b. (a -> b) -> a -> b
$
          forall e a. (Eq e, Monoid e, Ord a) => Graph e a -> [(e, a, a)]
LG.edgeList ActualGraph
ag
    violatingEdges :: [PackageViolation]
violatingEdges =
      forall a b. (a -> b) -> [a] -> [b]
map
        ( forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry DomainName -> DomainName -> Path PackageName -> PackageViolation
DomainBoundaryViolation
        )
        forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toList
        forall a b. (a -> b) -> a -> b
$ Map (DomainName, DomainName) (Path PackageName)
actualEdges forall k a. Ord k => Map k a -> Set k -> Map k a
`Map.withoutKeys` Set (DomainName, DomainName)
expectedEdges