{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}

module Development.Guardian.App (
  BuildInfo (..),
  defaultMain,
  defaultMainWith,
  reportPackageGraphValidation,
  buildInfoQ,
) where

import Control.Applicative ((<**>))
import qualified Data.Aeson as J
import Data.Foldable.WithIndex
import Data.Functor.WithIndex.Instances ()
import Data.List (intersperse)
import qualified Data.List.NonEmpty as NE
import qualified Data.Map.Strict as Map
import Data.Monoid (Sum (..))
import qualified Data.Set as Set
import Data.Version (Version (..), showVersion)
import qualified Data.Yaml as Y
import Development.Guardian.Constants (configFileName)
import Development.Guardian.Graph
import qualified Development.Guardian.Graph.Adapter.Cabal as Cabal
import Development.Guardian.Graph.Adapter.Detection (detectAdapterThrow)
import qualified Development.Guardian.Graph.Adapter.Stack as Stack
import Development.Guardian.Graph.Adapter.Types
import Development.Guardian.Types
import GitHash (GitInfo, giDirty, giHash, tGitInfoCwdTry)
import Language.Haskell.TH.Syntax
import qualified Options.Applicative as Opts
import Path
import Path.IO (canonicalizePath, getCurrentDir)
import RIO
import System.Environment (getArgs)
import Validation (validation, validationToEither)

data Option = Option
  { Option -> Maybe StandardAdapters
mode :: Maybe StandardAdapters
  , Option -> Maybe (SomeBase Dir)
target :: Maybe (SomeBase Dir)
  , Option -> Path Rel File
config :: Path Rel File
  }
  deriving (Int -> Option -> ShowS
[Option] -> ShowS
Option -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Option] -> ShowS
$cshowList :: [Option] -> ShowS
show :: Option -> String
$cshow :: Option -> String
showsPrec :: Int -> Option -> ShowS
$cshowsPrec :: Int -> Option -> ShowS
Show, Option -> Option -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Option -> Option -> Bool
$c/= :: Option -> Option -> Bool
== :: Option -> Option -> Bool
$c== :: Option -> Option -> Bool
Eq, Eq Option
Option -> Option -> Bool
Option -> Option -> Ordering
Option -> Option -> Option
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
min :: Option -> Option -> Option
$cmin :: Option -> Option -> Option
max :: Option -> Option -> Option
$cmax :: Option -> Option -> Option
>= :: Option -> Option -> Bool
$c>= :: Option -> Option -> Bool
> :: Option -> Option -> Bool
$c> :: Option -> Option -> Bool
<= :: Option -> Option -> Bool
$c<= :: Option -> Option -> Bool
< :: Option -> Option -> Bool
$c< :: Option -> Option -> Bool
compare :: Option -> Option -> Ordering
$ccompare :: Option -> Option -> Ordering
Ord)

data BuildInfo = BuildInfo {BuildInfo -> String
versionString :: String, BuildInfo -> Maybe GitInfo
gitInfo :: Maybe GitInfo}
  deriving (Int -> BuildInfo -> ShowS
[BuildInfo] -> ShowS
BuildInfo -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BuildInfo] -> ShowS
$cshowList :: [BuildInfo] -> ShowS
show :: BuildInfo -> String
$cshow :: BuildInfo -> String
showsPrec :: Int -> BuildInfo -> ShowS
$cshowsPrec :: Int -> BuildInfo -> ShowS
Show)

buildInfoQ :: Version -> Code Q BuildInfo
buildInfoQ :: Version -> Code Q BuildInfo
buildInfoQ Version
version =
  [||
  BuildInfo
    { versionString = $$(liftTyped $ showVersion version)
    , gitInfo = either (const Nothing) Just $$(tGitInfoCwdTry)
    }
  ||]

optsPI :: BuildInfo -> Opts.ParserInfo Option
optsPI :: BuildInfo -> ParserInfo Option
optsPI BuildInfo {String
Maybe GitInfo
gitInfo :: Maybe GitInfo
versionString :: String
gitInfo :: BuildInfo -> Maybe GitInfo
versionString :: BuildInfo -> String
..} = forall a. Parser a -> InfoMod a -> ParserInfo a
Opts.info (Parser Option
p forall (f :: * -> *) a b. Applicative f => f a -> f (a -> b) -> f b
<**> forall a. Parser (a -> a)
Opts.helper forall (f :: * -> *) a b. Applicative f => f a -> f (a -> b) -> f b
<**> forall a. Parser (a -> a)
versions) forall a. Monoid a => a
mempty
  where
    gitRev :: String
gitRev =
      forall b a. b -> (a -> b) -> Maybe a -> b
maybe
        String
""
        ( \GitInfo
gi ->
            String
", Git revision "
              forall a. Semigroup a => a -> a -> a
<> GitInfo -> String
giHash GitInfo
gi
              forall a. Semigroup a => a -> a -> a
<> if GitInfo -> Bool
giDirty GitInfo
gi then String
" (dirty)" else String
""
        )
        Maybe GitInfo
gitInfo
    verStr :: String
verStr = String
"Guardian Version " forall a. Semigroup a => a -> a -> a
<> String
versionString forall a. Semigroup a => a -> a -> a
<> String
gitRev
    versions :: Parser (a -> a)
versions = forall a. String -> Mod OptionFields (a -> a) -> Parser (a -> a)
Opts.infoOption String
verStr (forall (f :: * -> *) a. HasName f => String -> Mod f a
Opts.long String
"version" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasName f => Char -> Mod f a
Opts.short Char
'V' forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. String -> Mod f a
Opts.help String
"Prints version string and exit.")
    inP :: Maybe StandardAdapters -> Parser Option
inP Maybe StandardAdapters
mode = do
      Path Rel File
config <-
        forall a. ReadM a -> Mod OptionFields a -> Parser a
Opts.option (forall a. (String -> Either String a) -> ReadM a
Opts.eitherReader String -> Either String (Path Rel File)
parsFileP) forall a b. (a -> b) -> a -> b
$
          forall (f :: * -> *) a. HasName f => String -> Mod f a
Opts.long String
"config"
            forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasName f => Char -> Mod f a
Opts.short Char
'c'
            forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
Opts.metavar String
"PATH"
            forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasValue f => a -> Mod f a
Opts.value Path Rel File
configFileName
            forall a. Semigroup a => a -> a -> a
<> forall a (f :: * -> *). Show a => Mod f a
Opts.showDefault
            forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. String -> Mod f a
Opts.help String
"configuration file, relative to the target directory"

      Maybe (SomeBase Dir)
target <-
        forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional forall a b. (a -> b) -> a -> b
$
          forall a. ReadM a -> Mod ArgumentFields a -> Parser a
Opts.argument (forall a. (String -> Either String a) -> ReadM a
Opts.eitherReader String -> Either String (SomeBase Dir)
parseDirP) forall a b. (a -> b) -> a -> b
$
            forall (f :: * -> *) a. String -> Mod f a
Opts.help String
"input directory (uses current directory if missing)" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
Opts.metavar String
"DIR"
      pure Option {Maybe (SomeBase Dir)
Maybe StandardAdapters
Path Rel File
target :: Maybe (SomeBase Dir)
config :: Path Rel File
mode :: Maybe StandardAdapters
config :: Path Rel File
target :: Maybe (SomeBase Dir)
mode :: Maybe StandardAdapters
..}
    autoP :: ParserInfo Option
autoP =
      forall a. Parser a -> InfoMod a -> ParserInfo a
Opts.info (Maybe StandardAdapters -> Parser Option
inP forall a. Maybe a
Nothing) forall a b. (a -> b) -> a -> b
$
        forall a. String -> InfoMod a
Opts.progDesc String
"Defends borders against the auto-detected build-system"

    p :: Parser Option
p =
      forall a. Mod CommandFields a -> Parser a
Opts.hsubparser
        ( forall a. Monoid a => [a] -> a
mconcat
            [ forall a. String -> ParserInfo a -> Mod CommandFields a
Opts.command String
"auto" ParserInfo Option
autoP
            , forall a. String -> ParserInfo a -> Mod CommandFields a
Opts.command
                String
"stack"
                ( forall a. Parser a -> InfoMod a -> ParserInfo a
Opts.info (Maybe StandardAdapters -> Parser Option
inP forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just StandardAdapters
Stack) forall a b. (a -> b) -> a -> b
$
                    forall a. String -> InfoMod a
Opts.progDesc String
"Defends borders against stack.yaml"
                )
            , forall a. String -> ParserInfo a -> Mod CommandFields a
Opts.command
                String
"cabal"
                ( forall a. Parser a -> InfoMod a -> ParserInfo a
Opts.info (Maybe StandardAdapters -> Parser Option
inP forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just StandardAdapters
Cabal) forall a b. (a -> b) -> a -> b
$
                    forall a. String -> InfoMod a
Opts.progDesc String
"Defends borders against cabal.project"
                )
            ]
        )

parseDirP :: String -> Either String (SomeBase Dir)
parseDirP :: String -> Either String (SomeBase Dir)
parseDirP = forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). MonadThrow m => String -> m (SomeBase Dir)
parseSomeDir

parsFileP :: String -> Either String (Path Rel File)
parsFileP :: String -> Either String (Path Rel File)
parsFileP = forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile

data GuardianException
  = InvalidDependencyDomainYaml [DomainGraphError]
  | PackageGraphErrors [PackageViolation]
  deriving (Int -> GuardianException -> ShowS
[GuardianException] -> ShowS
GuardianException -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GuardianException] -> ShowS
$cshowList :: [GuardianException] -> ShowS
show :: GuardianException -> String
$cshow :: GuardianException -> String
showsPrec :: Int -> GuardianException -> ShowS
$cshowsPrec :: Int -> GuardianException -> ShowS
Show, GuardianException -> GuardianException -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GuardianException -> GuardianException -> Bool
$c/= :: GuardianException -> GuardianException -> Bool
== :: GuardianException -> GuardianException -> Bool
$c== :: GuardianException -> GuardianException -> Bool
Eq, Eq GuardianException
GuardianException -> GuardianException -> Bool
GuardianException -> GuardianException -> Ordering
GuardianException -> GuardianException -> GuardianException
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
min :: GuardianException -> GuardianException -> GuardianException
$cmin :: GuardianException -> GuardianException -> GuardianException
max :: GuardianException -> GuardianException -> GuardianException
$cmax :: GuardianException -> GuardianException -> GuardianException
>= :: GuardianException -> GuardianException -> Bool
$c>= :: GuardianException -> GuardianException -> Bool
> :: GuardianException -> GuardianException -> Bool
$c> :: GuardianException -> GuardianException -> Bool
<= :: GuardianException -> GuardianException -> Bool
$c<= :: GuardianException -> GuardianException -> Bool
< :: GuardianException -> GuardianException -> Bool
$c< :: GuardianException -> GuardianException -> Bool
compare :: GuardianException -> GuardianException -> Ordering
$ccompare :: GuardianException -> GuardianException -> Ordering
Ord)
  deriving anyclass (Show GuardianException
Typeable GuardianException
SomeException -> Maybe GuardianException
GuardianException -> String
GuardianException -> SomeException
forall e.
Typeable e
-> Show e
-> (e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> String)
-> Exception e
displayException :: GuardianException -> String
$cdisplayException :: GuardianException -> String
fromException :: SomeException -> Maybe GuardianException
$cfromException :: SomeException -> Maybe GuardianException
toException :: GuardianException -> SomeException
$ctoException :: GuardianException -> SomeException
Exception)

eitherResult :: J.Result a -> Either String a
eitherResult :: forall a. Result a -> Either String a
eitherResult (J.Error String
s) = forall a b. a -> Either a b
Left String
s
eitherResult (J.Success a
a) = forall a b. b -> Either a b
Right a
a

defaultMainWith ::
  (MonadUnliftIO m, MonadReader env m, HasLogFunc env) =>
  BuildInfo ->
  [String] ->
  m ()
defaultMainWith :: forall (m :: * -> *) env.
(MonadUnliftIO m, MonadReader env m, HasLogFunc env) =>
BuildInfo -> [String] -> m ()
defaultMainWith BuildInfo
buildInfo [String]
args = do
  Option {Maybe (SomeBase Dir)
Maybe StandardAdapters
Path Rel File
config :: Path Rel File
target :: Maybe (SomeBase Dir)
mode :: Maybe StandardAdapters
config :: Option -> Path Rel File
target :: Option -> Maybe (SomeBase Dir)
mode :: Option -> Maybe StandardAdapters
..} <-
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
      forall a. ParserResult a -> IO a
Opts.handleParseResult forall a b. (a -> b) -> a -> b
$
        forall a. ParserPrefs -> ParserInfo a -> [String] -> ParserResult a
Opts.execParserPure ParserPrefs
Opts.defaultPrefs (BuildInfo -> ParserInfo Option
optsPI BuildInfo
buildInfo) [String]
args
  Path Abs Dir
targ <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall (m :: * -> *). MonadIO m => m (Path Abs Dir)
getCurrentDir forall path (m :: * -> *).
(AnyPath path, MonadIO m) =>
path -> m (AbsPath path)
canonicalizePath Maybe (SomeBase Dir)
target
  forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Using configuration: " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => String -> a
fromString (Path Rel File -> String
fromRelFile Path Rel File
config)
  Value
yaml <- forall (m :: * -> *) a. (MonadIO m, FromJSON a) => String -> m a
Y.decodeFileThrow (Path Abs File -> String
fromAbsFile forall a b. (a -> b) -> a -> b
$ Path Abs Dir
targ forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
config)
  Domains
doms <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Result a -> Either String a
eitherResult forall a b. (a -> b) -> a -> b
$ forall a. FromJSON a => Value -> Result a
J.fromJSON Value
yaml

  StandardAdapters
mode' <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) b.
MonadIO m =>
Value -> Path b Dir -> m StandardAdapters
detectAdapterThrow Value
yaml Path Abs Dir
targ) forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe StandardAdapters
mode
  forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$
    Utf8Builder
"Checking dependency of "
      forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Utf8Builder
displayShow Path Abs Dir
targ
      forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" with backend "
      forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Utf8Builder
displayShow StandardAdapters
mode'
  PackageGraph
pkgGraph <- case StandardAdapters
mode' of
    StandardAdapters
Stack ->
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
        forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString (PackageGraphOptions Stack -> IO PackageGraph
Stack.buildPackageGraph forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall backend.
PackageBuildParser backend
-> Path Abs Dir -> PackageGraphOptions backend
withTargetPath Path Abs Dir
targ) forall a b. (a -> b) -> a -> b
$
          forall a. Result a -> Either String a
eitherResult forall a b. (a -> b) -> a -> b
$
            forall a. FromJSON a => Value -> Result a
J.fromJSON Value
yaml
    StandardAdapters
Cabal ->
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
        forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString (PackageGraphOptions Cabal -> IO PackageGraph
Cabal.buildPackageGraph forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall backend.
PackageBuildParser backend
-> Path Abs Dir -> PackageGraphOptions backend
withTargetPath Path Abs Dir
targ) forall a b. (a -> b) -> a -> b
$
          forall a. Result a -> Either String a
eitherResult forall a b. (a -> b) -> a -> b
$
            forall a. FromJSON a => Value -> Result a
J.fromJSON Value
yaml
  forall env (m :: * -> *).
(MonadReader env m, MonadIO m, HasLogFunc env) =>
Domains -> PackageGraph -> m ()
reportPackageGraphValidation Domains
doms PackageGraph
pkgGraph

reportPackageGraphValidation ::
  (MonadReader env m, MonadIO m, HasLogFunc env) =>
  Domains ->
  PackageGraph ->
  m ()
reportPackageGraphValidation :: forall env (m :: * -> *).
(MonadReader env m, MonadIO m, HasLogFunc env) =>
Domains -> PackageGraph -> m ()
reportPackageGraphValidation Domains
doms PackageGraph
pkgGraph = do
  let mdomInfo :: Validation (NonEmpty DomainGraphError) DomainInfo
mdomInfo = Domains -> Validation (NonEmpty DomainGraphError) DomainInfo
buildDomainInfo Domains
doms
  DomainInfo
domInfo <-
    forall e x a. (e -> x) -> (a -> x) -> Validation e a -> x
validation
      ( \NonEmpty DomainGraphError
errs -> do
          forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError Utf8Builder
"Errors exists in dependency domain definition!"
          forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> Utf8Builder
displayShow) NonEmpty DomainGraphError
errs
          forall (m :: * -> *) a. MonadIO m => m a
exitFailure
      )
      forall (f :: * -> *) a. Applicative f => a -> f a
pure
      Validation (NonEmpty DomainGraphError) DomainInfo
mdomInfo
  let chkResult :: Either (NonEmpty PackageViolation) CheckResult
chkResult =
        forall e a. Validation e a -> Either e a
validationToEither forall a b. (a -> b) -> a -> b
$
          DomainInfo
-> PackageGraph
-> Validation (NonEmpty PackageViolation) CheckResult
validatePackageGraph DomainInfo
domInfo PackageGraph
pkgGraph
  case Either (NonEmpty PackageViolation) CheckResult
chkResult of
    Left NonEmpty PackageViolation
errs -> do
      forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError forall a b. (a -> b) -> a -> b
$
        Utf8Builder
"Dependency domain violation(s): found "
          forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Utf8Builder
displayShow (forall a. NonEmpty a -> Int
NE.length NonEmpty PackageViolation
errs)
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> Utf8Builder
displayShow) NonEmpty PackageViolation
errs
      forall (m :: * -> *) a. MonadIO m => m a
exitFailure
    Right CheckResult
Ok -> forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"All dependency boundary is good!"
    Right (OkWithDiagnostics Diagnostics {Map PackageName (Set Dependency)
usedExceptionalRules :: Diagnostics -> Map PackageName (Set Dependency)
redundantExtraDeps :: Diagnostics -> Map PackageName (Set Dependency)
usedExceptionalRules :: Map PackageName (Set Dependency)
redundantExtraDeps :: Map PackageName (Set Dependency)
..}) -> do
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall k a. Map k a -> Bool
Map.null Map PackageName (Set Dependency)
usedExceptionalRules) forall a b. (a -> b) -> a -> b
$ do
        forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"------------------------------"
        forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"* Following exceptional rules are used:"
        forall i (t :: * -> *) (m :: * -> *) a b.
(FoldableWithIndex i t, Monad m) =>
t a -> (i -> a -> m b) -> m ()
iforM_ Map PackageName (Set Dependency)
usedExceptionalRules forall a b. (a -> b) -> a -> b
$ \PackageName
pkg Set Dependency
deps -> do
          let ds :: [Dependency]
ds = forall a. Set a -> [a]
Set.toList Set Dependency
deps
          forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$
            Utf8Builder
"    - "
              forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Utf8Builder
displayShow PackageName
pkg
              forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" depends on: "
              forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold
                (forall a. a -> [a] -> [a]
intersperse Utf8Builder
"," forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> Utf8Builder
displayShow [Dependency]
ds)

      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall k a. Map k a -> Bool
Map.null Map PackageName (Set Dependency)
redundantExtraDeps) forall a b. (a -> b) -> a -> b
$ do
        let reduntCount :: Int
reduntCount = forall a. Sum a -> a
getSum forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall a. a -> Sum a
Sum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> Int
Set.size) Map PackageName (Set Dependency)
redundantExtraDeps
        forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"------------------------------"
        forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$
          Utf8Builder
"* "
            forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Utf8Builder
displayShow Int
reduntCount
            forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" redundant exceptional dependency(s) found:"
        forall i (t :: * -> *) (m :: * -> *) a b.
(FoldableWithIndex i t, Monad m) =>
t a -> (i -> a -> m b) -> m ()
iforM_ Map PackageName (Set Dependency)
redundantExtraDeps forall a b. (a -> b) -> a -> b
$ \PackageName
pkg Set Dependency
deps -> do
          let ds :: [Dependency]
ds = forall a. Set a -> [a]
Set.toList Set Dependency
deps
          forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$
            Utf8Builder
"    - "
              forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Utf8Builder
displayShow PackageName
pkg
              forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" doesn't depends on: "
              forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (forall a. a -> [a] -> [a]
intersperse Utf8Builder
", " forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> Utf8Builder
displayShow [Dependency]
ds)
              forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"\n"

      forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"------------------------------"
      forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"All dependency boundary is good, with some additional warning."

defaultMain :: MonadUnliftIO m => BuildInfo -> m ()
defaultMain :: forall (m :: * -> *). MonadUnliftIO m => BuildInfo -> m ()
defaultMain BuildInfo
binfo = do
  LogOptions
logOpts <-
    forall (m :: * -> *). MonadIO m => Handle -> Bool -> m LogOptions
logOptionsHandle Handle
stdout Bool
True
      forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Bool -> LogOptions -> LogOptions
setLogUseTime Bool
False
      forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Bool -> LogOptions -> LogOptions
setLogUseLoc Bool
False
  forall (m :: * -> *) a.
MonadUnliftIO m =>
LogOptions -> (LogFunc -> m a) -> m a
withLogFunc LogOptions
logOpts forall a b. (a -> b) -> a -> b
$ \LogFunc
logFun -> do
    SimpleApp
app <- forall (m :: * -> *).
MonadIO m =>
LogFunc -> Maybe ProcessContext -> m SimpleApp
mkSimpleApp LogFunc
logFun forall a. Maybe a
Nothing
    forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO SimpleApp
app forall a b. (a -> b) -> a -> b
$
      forall (m :: * -> *) env.
(MonadUnliftIO m, MonadReader env m, HasLogFunc env) =>
BuildInfo -> [String] -> m ()
defaultMainWith BuildInfo
binfo forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [String]
getArgs