{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}

module Stack.Dot (dot
                 ,listDependencies
                 ,DotOpts(..)
                 ,DotPayload(..)
                 ,ListDepsOpts(..)
                 ,ListDepsFormat(..)
                 ,ListDepsFormatOpts(..)
                 ,resolveDependencies
                 ,printGraph
                 ,pruneGraph
                 ) where

import           Data.Aeson
import qualified Data.ByteString.Lazy.Char8 as LBC8
import qualified Data.Foldable as F
import qualified Data.Sequence as Seq
import qualified Data.Set as Set
import qualified Data.Map as Map
import qualified Data.Text as Text
import qualified Data.Text.IO as Text
import qualified Data.Traversable as T
import           Distribution.Text (display)
import qualified Distribution.PackageDescription as PD
import qualified Distribution.SPDX.License as SPDX
import           Distribution.License (License(BSD3), licenseFromSPDX)
import           Distribution.Types.PackageName (mkPackageName)
import qualified Path
import           RIO.PrettyPrint (HasTerm (..), HasStylesUpdate (..))
import           RIO.Process (HasProcessContext (..))
import           Stack.Build (loadPackage)
import           Stack.Build.Installed (getInstalled, toInstallMap)
import           Stack.Build.Source
import           Stack.Constants
import           Stack.Package
import           Stack.Prelude hiding (Display (..), pkgName, loadPackage)
import qualified Stack.Prelude (pkgName)
import           Stack.Runners
import           Stack.SourceMap
import           Stack.Types.Build
import           Stack.Types.Compiler (wantedToActual)
import           Stack.Types.Config
import           Stack.Types.GhcPkgId
import           Stack.Types.SourceMap
import           Stack.Build.Target(NeedTargets(..), parseTargets)

-- | Options record for @stack dot@
data DotOpts = DotOpts
    { DotOpts -> Bool
dotIncludeExternal :: !Bool
    -- ^ Include external dependencies
    , DotOpts -> Bool
dotIncludeBase :: !Bool
    -- ^ Include dependencies on base
    , DotOpts -> Maybe Int
dotDependencyDepth :: !(Maybe Int)
    -- ^ Limit the depth of dependency resolution to (Just n) or continue until fixpoint
    , DotOpts -> Set PackageName
dotPrune :: !(Set PackageName)
    -- ^ Package names to prune from the graph
    , DotOpts -> [Text]
dotTargets :: [Text]
    -- ^ stack TARGETs to trace dependencies for
    , DotOpts -> Map ApplyCLIFlag (Map FlagName Bool)
dotFlags :: !(Map ApplyCLIFlag (Map FlagName Bool))
    -- ^ Flags to apply when calculating dependencies
    , DotOpts -> Bool
dotTestTargets :: Bool
    -- ^ Like the "--test" flag for build, affects the meaning of 'dotTargets'.
    , DotOpts -> Bool
dotBenchTargets :: Bool
    -- ^ Like the "--bench" flag for build, affects the meaning of 'dotTargets'.
    , DotOpts -> Bool
dotGlobalHints :: Bool
    -- ^ Use global hints instead of relying on an actual GHC installation.
    }

data ListDepsFormatOpts = ListDepsFormatOpts { ListDepsFormatOpts -> Text
listDepsSep :: !Text
                                             -- ^ Separator between the package name and details.
                                             , ListDepsFormatOpts -> Bool
listDepsLicense :: !Bool
                                             -- ^ Print dependency licenses instead of versions.
                                             }

data ListDepsFormat = ListDepsText ListDepsFormatOpts
                    | ListDepsTree ListDepsFormatOpts
                    | ListDepsJSON

data ListDepsOpts = ListDepsOpts
    { ListDepsOpts -> ListDepsFormat
listDepsFormat :: !ListDepsFormat
    -- ^ Format of printing dependencies
    , ListDepsOpts -> DotOpts
listDepsDotOpts :: !DotOpts
    -- ^ The normal dot options.
    }

-- | Visualize the project's dependencies as a graphviz graph
dot :: DotOpts -> RIO Runner ()
dot :: DotOpts -> RIO Runner ()
dot DotOpts
dotOpts = do
  (Set PackageName
localNames, Map PackageName (Set PackageName, DotPayload)
prunedGraph) <- DotOpts
-> RIO
     Runner
     (Set PackageName, Map PackageName (Set PackageName, DotPayload))
createPrunedDependencyGraph DotOpts
dotOpts
  DotOpts
-> Set PackageName
-> Map PackageName (Set PackageName, DotPayload)
-> RIO Runner ()
forall (m :: * -> *).
(Applicative m, MonadIO m) =>
DotOpts
-> Set PackageName
-> Map PackageName (Set PackageName, DotPayload)
-> m ()
printGraph DotOpts
dotOpts Set PackageName
localNames Map PackageName (Set PackageName, DotPayload)
prunedGraph

-- | Information about a package in the dependency graph, when available.
data DotPayload = DotPayload
  { DotPayload -> Maybe Version
payloadVersion :: Maybe Version
  -- ^ The package version.
  , DotPayload -> Maybe (Either License License)
payloadLicense :: Maybe (Either SPDX.License License)
  -- ^ The license the package was released under.
  , DotPayload -> Maybe PackageLocation
payloadLocation :: Maybe PackageLocation
  -- ^ The location of the package.
  } deriving (DotPayload -> DotPayload -> Bool
(DotPayload -> DotPayload -> Bool)
-> (DotPayload -> DotPayload -> Bool) -> Eq DotPayload
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DotPayload -> DotPayload -> Bool
$c/= :: DotPayload -> DotPayload -> Bool
== :: DotPayload -> DotPayload -> Bool
$c== :: DotPayload -> DotPayload -> Bool
Eq, Int -> DotPayload -> ShowS
[DotPayload] -> ShowS
DotPayload -> String
(Int -> DotPayload -> ShowS)
-> (DotPayload -> String)
-> ([DotPayload] -> ShowS)
-> Show DotPayload
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DotPayload] -> ShowS
$cshowList :: [DotPayload] -> ShowS
show :: DotPayload -> String
$cshow :: DotPayload -> String
showsPrec :: Int -> DotPayload -> ShowS
$cshowsPrec :: Int -> DotPayload -> ShowS
Show)

-- | Create the dependency graph and also prune it as specified in the dot
-- options. Returns a set of local names and and a map from package names to
-- dependencies.
createPrunedDependencyGraph :: DotOpts
                            -> RIO Runner
                                 (Set PackageName,
                                  Map PackageName (Set PackageName, DotPayload))
createPrunedDependencyGraph :: DotOpts
-> RIO
     Runner
     (Set PackageName, Map PackageName (Set PackageName, DotPayload))
createPrunedDependencyGraph DotOpts
dotOpts = DotOpts
-> RIO
     DotConfig
     (Set PackageName, Map PackageName (Set PackageName, DotPayload))
-> RIO
     Runner
     (Set PackageName, Map PackageName (Set PackageName, DotPayload))
forall a. DotOpts -> RIO DotConfig a -> RIO Runner a
withDotConfig DotOpts
dotOpts (RIO
   DotConfig
   (Set PackageName, Map PackageName (Set PackageName, DotPayload))
 -> RIO
      Runner
      (Set PackageName, Map PackageName (Set PackageName, DotPayload)))
-> RIO
     DotConfig
     (Set PackageName, Map PackageName (Set PackageName, DotPayload))
-> RIO
     Runner
     (Set PackageName, Map PackageName (Set PackageName, DotPayload))
forall a b. (a -> b) -> a -> b
$ do
  Set PackageName
localNames <- Getting (Set PackageName) DotConfig (Set PackageName)
-> RIO DotConfig (Set PackageName)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting (Set PackageName) DotConfig (Set PackageName)
 -> RIO DotConfig (Set PackageName))
-> Getting (Set PackageName) DotConfig (Set PackageName)
-> RIO DotConfig (Set PackageName)
forall a b. (a -> b) -> a -> b
$ (BuildConfig -> Const (Set PackageName) BuildConfig)
-> DotConfig -> Const (Set PackageName) DotConfig
forall env. HasBuildConfig env => Lens' env BuildConfig
buildConfigL((BuildConfig -> Const (Set PackageName) BuildConfig)
 -> DotConfig -> Const (Set PackageName) DotConfig)
-> ((Set PackageName -> Const (Set PackageName) (Set PackageName))
    -> BuildConfig -> Const (Set PackageName) BuildConfig)
-> Getting (Set PackageName) DotConfig (Set PackageName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(BuildConfig -> Set PackageName)
-> SimpleGetter BuildConfig (Set PackageName)
forall s a. (s -> a) -> SimpleGetter s a
to (Map PackageName ProjectPackage -> Set PackageName
forall k a. Map k a -> Set k
Map.keysSet (Map PackageName ProjectPackage -> Set PackageName)
-> (BuildConfig -> Map PackageName ProjectPackage)
-> BuildConfig
-> Set PackageName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SMWanted -> Map PackageName ProjectPackage
smwProject (SMWanted -> Map PackageName ProjectPackage)
-> (BuildConfig -> SMWanted)
-> BuildConfig
-> Map PackageName ProjectPackage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BuildConfig -> SMWanted
bcSMWanted)
  Utf8Builder -> RIO DotConfig ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Creating dependency graph"
  Map PackageName (Set PackageName, DotPayload)
resultGraph <- DotOpts
-> RIO DotConfig (Map PackageName (Set PackageName, DotPayload))
createDependencyGraph DotOpts
dotOpts
  let pkgsToPrune :: Set PackageName
pkgsToPrune = if DotOpts -> Bool
dotIncludeBase DotOpts
dotOpts
                       then DotOpts -> Set PackageName
dotPrune DotOpts
dotOpts
                       else PackageName -> Set PackageName -> Set PackageName
forall a. Ord a => a -> Set a -> Set a
Set.insert PackageName
"base" (DotOpts -> Set PackageName
dotPrune DotOpts
dotOpts)
      prunedGraph :: Map PackageName (Set PackageName, DotPayload)
prunedGraph = Set PackageName
-> Set PackageName
-> Map PackageName (Set PackageName, DotPayload)
-> Map PackageName (Set PackageName, DotPayload)
forall (f :: * -> *) (g :: * -> *) a.
(Foldable f, Foldable g, Eq a) =>
f PackageName
-> g PackageName
-> Map PackageName (Set PackageName, a)
-> Map PackageName (Set PackageName, a)
pruneGraph Set PackageName
localNames Set PackageName
pkgsToPrune Map PackageName (Set PackageName, DotPayload)
resultGraph
  Utf8Builder -> RIO DotConfig ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Returning prouned dependency graph"
  (Set PackageName, Map PackageName (Set PackageName, DotPayload))
-> RIO
     DotConfig
     (Set PackageName, Map PackageName (Set PackageName, DotPayload))
forall (m :: * -> *) a. Monad m => a -> m a
return (Set PackageName
localNames, Map PackageName (Set PackageName, DotPayload)
prunedGraph)

-- | Create the dependency graph, the result is a map from a package
-- name to a tuple of dependencies and payload if available. This
-- function mainly gathers the required arguments for
-- @resolveDependencies@.
createDependencyGraph
  :: DotOpts
  -> RIO DotConfig (Map PackageName (Set PackageName, DotPayload))
createDependencyGraph :: DotOpts
-> RIO DotConfig (Map PackageName (Set PackageName, DotPayload))
createDependencyGraph DotOpts
dotOpts = do
  SourceMap
sourceMap <- Getting SourceMap DotConfig SourceMap -> RIO DotConfig SourceMap
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting SourceMap DotConfig SourceMap
forall env. HasSourceMap env => Lens' env SourceMap
sourceMapL
  [LocalPackage]
locals <- [ProjectPackage]
-> (ProjectPackage -> RIO DotConfig LocalPackage)
-> RIO DotConfig [LocalPackage]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (Map PackageName ProjectPackage -> [ProjectPackage]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Map PackageName ProjectPackage -> [ProjectPackage])
-> Map PackageName ProjectPackage -> [ProjectPackage]
forall a b. (a -> b) -> a -> b
$ SourceMap -> Map PackageName ProjectPackage
smProject SourceMap
sourceMap) ProjectPackage -> RIO DotConfig LocalPackage
forall env.
(HasBuildConfig env, HasSourceMap env) =>
ProjectPackage -> RIO env LocalPackage
loadLocalPackage
  let graph :: Map PackageName (Set PackageName, DotPayload)
graph = [(PackageName, (Set PackageName, DotPayload))]
-> Map PackageName (Set PackageName, DotPayload)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(PackageName, (Set PackageName, DotPayload))]
 -> Map PackageName (Set PackageName, DotPayload))
-> [(PackageName, (Set PackageName, DotPayload))]
-> Map PackageName (Set PackageName, DotPayload)
forall a b. (a -> b) -> a -> b
$ DotOpts
-> [LocalPackage] -> [(PackageName, (Set PackageName, DotPayload))]
projectPackageDependencies DotOpts
dotOpts ((LocalPackage -> Bool) -> [LocalPackage] -> [LocalPackage]
forall a. (a -> Bool) -> [a] -> [a]
filter LocalPackage -> Bool
lpWanted [LocalPackage]
locals)
  [DumpPackage]
globalDump <- Getting [DumpPackage] DotConfig [DumpPackage]
-> RIO DotConfig [DumpPackage]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting [DumpPackage] DotConfig [DumpPackage]
 -> RIO DotConfig [DumpPackage])
-> Getting [DumpPackage] DotConfig [DumpPackage]
-> RIO DotConfig [DumpPackage]
forall a b. (a -> b) -> a -> b
$ (DotConfig -> [DumpPackage])
-> SimpleGetter DotConfig [DumpPackage]
forall s a. (s -> a) -> SimpleGetter s a
to DotConfig -> [DumpPackage]
dcGlobalDump
  -- TODO: Can there be multiple entries for wired-in-packages? If so,
  -- this will choose one arbitrarily..
  let globalDumpMap :: Map PackageName DumpPackage
globalDumpMap = [(PackageName, DumpPackage)] -> Map PackageName DumpPackage
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(PackageName, DumpPackage)] -> Map PackageName DumpPackage)
-> [(PackageName, DumpPackage)] -> Map PackageName DumpPackage
forall a b. (a -> b) -> a -> b
$ (DumpPackage -> (PackageName, DumpPackage))
-> [DumpPackage] -> [(PackageName, DumpPackage)]
forall a b. (a -> b) -> [a] -> [b]
map (\DumpPackage
dp -> (PackageIdentifier -> PackageName
Stack.Prelude.pkgName (DumpPackage -> PackageIdentifier
dpPackageIdent DumpPackage
dp), DumpPackage
dp)) [DumpPackage]
globalDump
      globalIdMap :: Map GhcPkgId PackageIdentifier
globalIdMap = [(GhcPkgId, PackageIdentifier)] -> Map GhcPkgId PackageIdentifier
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(GhcPkgId, PackageIdentifier)] -> Map GhcPkgId PackageIdentifier)
-> [(GhcPkgId, PackageIdentifier)]
-> Map GhcPkgId PackageIdentifier
forall a b. (a -> b) -> a -> b
$ (DumpPackage -> (GhcPkgId, PackageIdentifier))
-> [DumpPackage] -> [(GhcPkgId, PackageIdentifier)]
forall a b. (a -> b) -> [a] -> [b]
map (\DumpPackage
dp -> (DumpPackage -> GhcPkgId
dpGhcPkgId DumpPackage
dp, DumpPackage -> PackageIdentifier
dpPackageIdent DumpPackage
dp)) [DumpPackage]
globalDump
  let depLoader :: PackageName -> RIO DotConfig (Set PackageName, DotPayload)
depLoader = SourceMap
-> Map PackageName DumpPackage
-> Map GhcPkgId PackageIdentifier
-> (PackageName
    -> Version
    -> PackageLocationImmutable
    -> Map FlagName Bool
    -> [Text]
    -> [Text]
    -> RIO DotConfig (Set PackageName, DotPayload))
-> PackageName
-> RIO DotConfig (Set PackageName, DotPayload)
createDepLoader SourceMap
sourceMap Map PackageName DumpPackage
globalDumpMap Map GhcPkgId PackageIdentifier
globalIdMap PackageName
-> Version
-> PackageLocationImmutable
-> Map FlagName Bool
-> [Text]
-> [Text]
-> RIO DotConfig (Set PackageName, DotPayload)
forall env.
(HasBuildConfig env, HasSourceMap env) =>
PackageName
-> Version
-> PackageLocationImmutable
-> Map FlagName Bool
-> [Text]
-> [Text]
-> RIO env (Set PackageName, DotPayload)
loadPackageDeps
      loadPackageDeps :: PackageName
-> Version
-> PackageLocationImmutable
-> Map FlagName Bool
-> [Text]
-> [Text]
-> RIO env (Set PackageName, DotPayload)
loadPackageDeps PackageName
name Version
version PackageLocationImmutable
loc Map FlagName Bool
flags [Text]
ghcOptions [Text]
cabalConfigOpts
          -- Skip packages that can't be loaded - see
          -- https://github.com/commercialhaskell/stack/issues/2967
          | PackageName
name PackageName -> [PackageName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String -> PackageName
mkPackageName String
"rts", String -> PackageName
mkPackageName String
"ghc"] =
              (Set PackageName, DotPayload)
-> RIO env (Set PackageName, DotPayload)
forall (m :: * -> *) a. Monad m => a -> m a
return (Set PackageName
forall a. Set a
Set.empty, Maybe Version
-> Maybe (Either License License)
-> Maybe PackageLocation
-> DotPayload
DotPayload (Version -> Maybe Version
forall a. a -> Maybe a
Just Version
version) (Either License License -> Maybe (Either License License)
forall a. a -> Maybe a
Just (Either License License -> Maybe (Either License License))
-> Either License License -> Maybe (Either License License)
forall a b. (a -> b) -> a -> b
$ License -> Either License License
forall a b. b -> Either a b
Right License
BSD3) Maybe PackageLocation
forall a. Maybe a
Nothing)
          | Bool
otherwise =
              (Package -> (Set PackageName, DotPayload))
-> RIO env Package -> RIO env (Set PackageName, DotPayload)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Package -> Set PackageName
packageAllDeps (Package -> Set PackageName)
-> (Package -> DotPayload)
-> Package
-> (Set PackageName, DotPayload)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& PackageLocationImmutable -> Package -> DotPayload
makePayload PackageLocationImmutable
loc) (PackageLocationImmutable
-> Map FlagName Bool -> [Text] -> [Text] -> RIO env Package
forall env.
(HasBuildConfig env, HasSourceMap env) =>
PackageLocationImmutable
-> Map FlagName Bool -> [Text] -> [Text] -> RIO env Package
loadPackage PackageLocationImmutable
loc Map FlagName Bool
flags [Text]
ghcOptions [Text]
cabalConfigOpts)
  Maybe Int
-> Map PackageName (Set PackageName, DotPayload)
-> (PackageName -> RIO DotConfig (Set PackageName, DotPayload))
-> RIO DotConfig (Map PackageName (Set PackageName, DotPayload))
forall (m :: * -> *).
(Applicative m, Monad m) =>
Maybe Int
-> Map PackageName (Set PackageName, DotPayload)
-> (PackageName -> m (Set PackageName, DotPayload))
-> m (Map PackageName (Set PackageName, DotPayload))
resolveDependencies (DotOpts -> Maybe Int
dotDependencyDepth DotOpts
dotOpts) Map PackageName (Set PackageName, DotPayload)
graph PackageName -> RIO DotConfig (Set PackageName, DotPayload)
depLoader
  where makePayload :: PackageLocationImmutable -> Package -> DotPayload
makePayload PackageLocationImmutable
loc Package
pkg = Maybe Version
-> Maybe (Either License License)
-> Maybe PackageLocation
-> DotPayload
DotPayload (Version -> Maybe Version
forall a. a -> Maybe a
Just (Version -> Maybe Version) -> Version -> Maybe Version
forall a b. (a -> b) -> a -> b
$ Package -> Version
packageVersion Package
pkg) (Either License License -> Maybe (Either License License)
forall a. a -> Maybe a
Just (Either License License -> Maybe (Either License License))
-> Either License License -> Maybe (Either License License)
forall a b. (a -> b) -> a -> b
$ Package -> Either License License
packageLicense Package
pkg) (PackageLocation -> Maybe PackageLocation
forall a. a -> Maybe a
Just (PackageLocation -> Maybe PackageLocation)
-> PackageLocation -> Maybe PackageLocation
forall a b. (a -> b) -> a -> b
$ PackageLocationImmutable -> PackageLocation
PLImmutable PackageLocationImmutable
loc)

listDependencies
  :: ListDepsOpts
  -> RIO Runner ()
listDependencies :: ListDepsOpts -> RIO Runner ()
listDependencies ListDepsOpts
opts = do
  let dotOpts :: DotOpts
dotOpts = ListDepsOpts -> DotOpts
listDepsDotOpts ListDepsOpts
opts
  (Set PackageName
pkgs, Map PackageName (Set PackageName, DotPayload)
resultGraph) <- DotOpts
-> RIO
     Runner
     (Set PackageName, Map PackageName (Set PackageName, DotPayload))
createPrunedDependencyGraph DotOpts
dotOpts
  IO () -> RIO Runner ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO Runner ()) -> IO () -> RIO Runner ()
forall a b. (a -> b) -> a -> b
$ case ListDepsOpts -> ListDepsFormat
listDepsFormat ListDepsOpts
opts of
      ListDepsTree ListDepsFormatOpts
treeOpts -> Text -> IO ()
Text.putStrLn Text
"Packages" IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ListDepsFormatOpts
-> DotOpts
-> Int
-> [Int]
-> Set PackageName
-> Map PackageName (Set PackageName, DotPayload)
-> IO ()
printTree ListDepsFormatOpts
treeOpts DotOpts
dotOpts Int
0 [] (ListDepsOpts -> Set PackageName -> Set PackageName
treeRoots ListDepsOpts
opts Set PackageName
pkgs) Map PackageName (Set PackageName, DotPayload)
resultGraph
      ListDepsFormat
ListDepsJSON -> Set PackageName
-> Map PackageName (Set PackageName, DotPayload) -> IO ()
printJSON Set PackageName
pkgs Map PackageName (Set PackageName, DotPayload)
resultGraph
      ListDepsText ListDepsFormatOpts
textOpts -> IO (Map PackageName ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ((PackageName -> DotPayload -> IO ())
-> Map PackageName DotPayload -> IO (Map PackageName ())
forall (t :: * -> *) k a b.
Applicative t =>
(k -> a -> t b) -> Map k a -> t (Map k b)
Map.traverseWithKey PackageName -> DotPayload -> IO ()
go ((Set PackageName, DotPayload) -> DotPayload
forall a b. (a, b) -> b
snd ((Set PackageName, DotPayload) -> DotPayload)
-> Map PackageName (Set PackageName, DotPayload)
-> Map PackageName DotPayload
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map PackageName (Set PackageName, DotPayload)
resultGraph))
        where go :: PackageName -> DotPayload -> IO ()
go PackageName
name DotPayload
payload = Text -> IO ()
Text.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ ListDepsFormatOpts -> PackageName -> DotPayload -> Text
listDepsLine ListDepsFormatOpts
textOpts PackageName
name DotPayload
payload

data DependencyTree = DependencyTree (Set PackageName) (Map PackageName (Set PackageName, DotPayload))

instance ToJSON DependencyTree where
  toJSON :: DependencyTree -> Value
toJSON (DependencyTree Set PackageName
_ Map PackageName (Set PackageName, DotPayload)
dependencyMap) =
    [Value] -> Value
forall a. ToJSON a => a -> Value
toJSON ([Value] -> Value) -> [Value] -> Value
forall a b. (a -> b) -> a -> b
$ (PackageName -> (Set PackageName, DotPayload) -> Value)
-> Map PackageName (Set PackageName, DotPayload) -> [Value]
forall k a b. (k -> a -> b) -> Map k a -> [b]
foldToList PackageName -> (Set PackageName, DotPayload) -> Value
dependencyToJSON Map PackageName (Set PackageName, DotPayload)
dependencyMap

foldToList :: (k -> a -> b) -> Map k a -> [b]
foldToList :: (k -> a -> b) -> Map k a -> [b]
foldToList k -> a -> b
f = (k -> a -> [b] -> [b]) -> [b] -> Map k a -> [b]
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey (\k
k a
a [b]
bs -> [b]
bs [b] -> [b] -> [b]
forall a. [a] -> [a] -> [a]
++ [k -> a -> b
f k
k a
a]) []

dependencyToJSON :: PackageName -> (Set PackageName, DotPayload) -> Value
dependencyToJSON :: PackageName -> (Set PackageName, DotPayload) -> Value
dependencyToJSON PackageName
pkg (Set PackageName
deps, DotPayload
payload) =  let fieldsAlwaysPresent :: [Pair]
fieldsAlwaysPresent = [ Text
"name" Text -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= PackageName -> String
packageNameString PackageName
pkg
                                                                  , Text
"license" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= DotPayload -> Text
licenseText DotPayload
payload
                                                                  , Text
"version" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= DotPayload -> Text
versionText DotPayload
payload
                                                                  , Text
"dependencies" Text -> Set String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (PackageName -> String) -> Set PackageName -> Set String
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map PackageName -> String
packageNameString Set PackageName
deps
                                                                  ]
                                            loc :: [Pair]
loc = [Maybe Pair] -> [Pair]
forall a. [Maybe a] -> [a]
catMaybes [(Text
"location" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.=) (Value -> Pair)
-> (PackageLocation -> Value) -> PackageLocation -> Pair
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageLocation -> Value
pkgLocToJSON (PackageLocation -> Pair) -> Maybe PackageLocation -> Maybe Pair
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DotPayload -> Maybe PackageLocation
payloadLocation DotPayload
payload]
                                        in [Pair] -> Value
object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$ [Pair]
fieldsAlwaysPresent [Pair] -> [Pair] -> [Pair]
forall a. [a] -> [a] -> [a]
++ [Pair]
loc

pkgLocToJSON :: PackageLocation -> Value
pkgLocToJSON :: PackageLocation -> Value
pkgLocToJSON (PLMutable (ResolvedPath RelFilePath
_ Path Abs Dir
dir)) = [Pair] -> Value
object [ Text
"type" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (Text
"project package" :: Text)
                                              , Text
"url" Text -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (String
"file://" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Path Abs Dir -> String
forall b t. Path b t -> String
Path.toFilePath Path Abs Dir
dir)]
pkgLocToJSON (PLImmutable (PLIHackage PackageIdentifier
pkgid BlobKey
_ TreeKey
_)) = [Pair] -> Value
object [ Text
"type" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (Text
"hackage" :: Text)
                                                  , Text
"url" Text -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (String
"https://hackage.haskell.org/package/" String -> ShowS
forall a. [a] -> [a] -> [a]
++ PackageIdentifier -> String
forall a. Pretty a => a -> String
display PackageIdentifier
pkgid)]
pkgLocToJSON (PLImmutable (PLIArchive Archive
archive PackageMetadata
_)) = let url :: Text
url = case Archive -> ArchiveLocation
archiveLocation Archive
archive of
                                                                ALUrl Text
u -> Text
u
                                                                ALFilePath (ResolvedPath RelFilePath
_ Path Abs File
path) -> String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"file://" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Path Abs File -> String
forall b t. Path b t -> String
Path.toFilePath Path Abs File
path
                                                    in [Pair] -> Value
object [ Text
"type" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (Text
"archive" :: Text)
                                                              , Text
"url" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text
url
                                                              , Text
"sha256" Text -> SHA256 -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Archive -> SHA256
archiveHash Archive
archive
                                                              , Text
"size" Text -> FileSize -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Archive -> FileSize
archiveSize Archive
archive ]
pkgLocToJSON (PLImmutable (PLIRepo Repo
repo PackageMetadata
_)) = [Pair] -> Value
object [ Text
"type" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= case Repo -> RepoType
repoType Repo
repo of
                                                                   RepoType
RepoGit -> Text
"git" :: Text
                                                                   RepoType
RepoHg -> Text
"hg" :: Text
                                                     , Text
"url" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Repo -> Text
repoUrl Repo
repo
                                                     , Text
"commit" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Repo -> Text
repoCommit Repo
repo
                                                     , Text
"subdir" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Repo -> Text
repoSubdir Repo
repo
                                                     ]

printJSON :: Set PackageName
          -> Map PackageName (Set PackageName, DotPayload)
          -> IO ()
printJSON :: Set PackageName
-> Map PackageName (Set PackageName, DotPayload) -> IO ()
printJSON Set PackageName
pkgs Map PackageName (Set PackageName, DotPayload)
dependencyMap = ByteString -> IO ()
LBC8.putStrLn (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ DependencyTree -> ByteString
forall a. ToJSON a => a -> ByteString
encode (DependencyTree -> ByteString) -> DependencyTree -> ByteString
forall a b. (a -> b) -> a -> b
$ Set PackageName
-> Map PackageName (Set PackageName, DotPayload) -> DependencyTree
DependencyTree Set PackageName
pkgs Map PackageName (Set PackageName, DotPayload)
dependencyMap

treeRoots :: ListDepsOpts -> Set PackageName -> Set PackageName
treeRoots :: ListDepsOpts -> Set PackageName -> Set PackageName
treeRoots ListDepsOpts
opts Set PackageName
projectPackages' =
  let targets :: [Text]
targets = DotOpts -> [Text]
dotTargets (DotOpts -> [Text]) -> DotOpts -> [Text]
forall a b. (a -> b) -> a -> b
$ ListDepsOpts -> DotOpts
listDepsDotOpts ListDepsOpts
opts
   in if [Text] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
targets
        then Set PackageName
projectPackages'
        else [PackageName] -> Set PackageName
forall a. Ord a => [a] -> Set a
Set.fromList ([PackageName] -> Set PackageName)
-> [PackageName] -> Set PackageName
forall a b. (a -> b) -> a -> b
$ (Text -> PackageName) -> [Text] -> [PackageName]
forall a b. (a -> b) -> [a] -> [b]
map (String -> PackageName
mkPackageName (String -> PackageName) -> (Text -> String) -> Text -> PackageName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack) [Text]
targets

printTree :: ListDepsFormatOpts
          -> DotOpts
          -> Int
          -> [Int]
          -> Set PackageName
          -> Map PackageName (Set PackageName, DotPayload)
          -> IO ()
printTree :: ListDepsFormatOpts
-> DotOpts
-> Int
-> [Int]
-> Set PackageName
-> Map PackageName (Set PackageName, DotPayload)
-> IO ()
printTree ListDepsFormatOpts
opts DotOpts
dotOpts Int
depth [Int]
remainingDepsCounts Set PackageName
packages Map PackageName (Set PackageName, DotPayload)
dependencyMap =
  Seq (IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
F.sequence_ (Seq (IO ()) -> IO ()) -> Seq (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int -> PackageName -> IO ()) -> Seq PackageName -> Seq (IO ())
forall a b. (Int -> a -> b) -> Seq a -> Seq b
Seq.mapWithIndex Int -> PackageName -> IO ()
go (Set PackageName -> Seq PackageName
forall a. Set a -> Seq a
toSeq Set PackageName
packages)
  where
    toSeq :: Set a -> Seq a
toSeq = [a] -> Seq a
forall a. [a] -> Seq a
Seq.fromList ([a] -> Seq a) -> (Set a -> [a]) -> Set a -> Seq a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set a -> [a]
forall a. Set a -> [a]
Set.toList
    go :: Int -> PackageName -> IO ()
go Int
index PackageName
name = let newDepsCounts :: [Int]
newDepsCounts = [Int]
remainingDepsCounts [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Set PackageName -> Int
forall a. Set a -> Int
Set.size Set PackageName
packages Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
index Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
                     in
                      case PackageName
-> Map PackageName (Set PackageName, DotPayload)
-> Maybe (Set PackageName, DotPayload)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
name Map PackageName (Set PackageName, DotPayload)
dependencyMap of
                        Just (Set PackageName
deps, DotPayload
payload) -> do
                          ListDepsFormatOpts
-> DotOpts
-> Int
-> [Int]
-> Set PackageName
-> DotPayload
-> PackageName
-> IO ()
printTreeNode ListDepsFormatOpts
opts DotOpts
dotOpts Int
depth [Int]
newDepsCounts Set PackageName
deps DotPayload
payload PackageName
name
                          if Int -> Maybe Int
forall a. a -> Maybe a
Just Int
depth Maybe Int -> Maybe Int -> Bool
forall a. Eq a => a -> a -> Bool
== DotOpts -> Maybe Int
dotDependencyDepth DotOpts
dotOpts
                             then () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                             else ListDepsFormatOpts
-> DotOpts
-> Int
-> [Int]
-> Set PackageName
-> Map PackageName (Set PackageName, DotPayload)
-> IO ()
printTree ListDepsFormatOpts
opts DotOpts
dotOpts (Int
depth Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [Int]
newDepsCounts Set PackageName
deps Map PackageName (Set PackageName, DotPayload)
dependencyMap
                        -- TODO: Define this behaviour, maybe return an error?
                        Maybe (Set PackageName, DotPayload)
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

printTreeNode :: ListDepsFormatOpts
              -> DotOpts
              -> Int
              -> [Int]
              -> Set PackageName
              -> DotPayload
              -> PackageName
              -> IO ()
printTreeNode :: ListDepsFormatOpts
-> DotOpts
-> Int
-> [Int]
-> Set PackageName
-> DotPayload
-> PackageName
-> IO ()
printTreeNode ListDepsFormatOpts
opts DotOpts
dotOpts Int
depth [Int]
remainingDepsCounts Set PackageName
deps DotPayload
payload PackageName
name =
  let remainingDepth :: Int
remainingDepth = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
999 (DotOpts -> Maybe Int
dotDependencyDepth DotOpts
dotOpts) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
depth
      hasDeps :: Bool
hasDeps = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Set PackageName -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Set PackageName
deps
   in Text -> IO ()
Text.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> [Int] -> Bool -> Int -> Text
treeNodePrefix Text
"" [Int]
remainingDepsCounts Bool
hasDeps  Int
remainingDepth  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ListDepsFormatOpts -> PackageName -> DotPayload -> Text
listDepsLine ListDepsFormatOpts
opts PackageName
name DotPayload
payload

treeNodePrefix :: Text -> [Int] -> Bool -> Int -> Text
treeNodePrefix :: Text -> [Int] -> Bool -> Int -> Text
treeNodePrefix Text
t [] Bool
_ Int
_      = Text
t
treeNodePrefix Text
t [Int
0] Bool
True  Int
0 = Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"└──"
treeNodePrefix Text
t [Int
_] Bool
True  Int
0 = Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"├──"
treeNodePrefix Text
t [Int
0] Bool
True  Int
_ = Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"└─┬"
treeNodePrefix Text
t [Int
_] Bool
True  Int
_ = Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"├─┬"
treeNodePrefix Text
t [Int
0] Bool
False Int
_ = Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"└──"
treeNodePrefix Text
t [Int
_] Bool
False Int
_ = Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"├──"
treeNodePrefix Text
t (Int
0:[Int]
ns) Bool
d Int
remainingDepth = Text -> [Int] -> Bool -> Int -> Text
treeNodePrefix (Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"  ") [Int]
ns Bool
d Int
remainingDepth
treeNodePrefix Text
t (Int
_:[Int]
ns) Bool
d Int
remainingDepth = Text -> [Int] -> Bool -> Int -> Text
treeNodePrefix (Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"│ ") [Int]
ns Bool
d Int
remainingDepth

listDepsLine :: ListDepsFormatOpts -> PackageName -> DotPayload -> Text
listDepsLine :: ListDepsFormatOpts -> PackageName -> DotPayload -> Text
listDepsLine ListDepsFormatOpts
opts PackageName
name DotPayload
payload = String -> Text
Text.pack (PackageName -> String
packageNameString PackageName
name) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ListDepsFormatOpts -> Text
listDepsSep ListDepsFormatOpts
opts Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ListDepsFormatOpts -> DotPayload -> Text
payloadText ListDepsFormatOpts
opts DotPayload
payload

payloadText :: ListDepsFormatOpts -> DotPayload -> Text
payloadText :: ListDepsFormatOpts -> DotPayload -> Text
payloadText ListDepsFormatOpts
opts DotPayload
payload =
  if ListDepsFormatOpts -> Bool
listDepsLicense ListDepsFormatOpts
opts
    then DotPayload -> Text
licenseText DotPayload
payload
    else DotPayload -> Text
versionText DotPayload
payload

licenseText :: DotPayload -> Text
licenseText :: DotPayload -> Text
licenseText DotPayload
payload = Text
-> (Either License License -> Text)
-> Maybe (Either License License)
-> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"<unknown>" (String -> Text
Text.pack (String -> Text)
-> (Either License License -> String)
-> Either License License
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. License -> String
forall a. Pretty a => a -> String
display (License -> String)
-> (Either License License -> License)
-> Either License License
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (License -> License)
-> (License -> License) -> Either License License -> License
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either License -> License
licenseFromSPDX License -> License
forall a. a -> a
id) (DotPayload -> Maybe (Either License License)
payloadLicense DotPayload
payload)

versionText :: DotPayload -> Text
versionText :: DotPayload -> Text
versionText DotPayload
payload = Text -> (Version -> Text) -> Maybe Version -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"<unknown>" (String -> Text
Text.pack (String -> Text) -> (Version -> String) -> Version -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> String
forall a. Pretty a => a -> String
display) (DotPayload -> Maybe Version
payloadVersion DotPayload
payload)

-- | @pruneGraph dontPrune toPrune graph@ prunes all packages in
-- @graph@ with a name in @toPrune@ and removes resulting orphans
-- unless they are in @dontPrune@
pruneGraph :: (F.Foldable f, F.Foldable g, Eq a)
           => f PackageName
           -> g PackageName
           -> Map PackageName (Set PackageName, a)
           -> Map PackageName (Set PackageName, a)
pruneGraph :: f PackageName
-> g PackageName
-> Map PackageName (Set PackageName, a)
-> Map PackageName (Set PackageName, a)
pruneGraph f PackageName
dontPrune g PackageName
names =
  f PackageName
-> Map PackageName (Set PackageName, a)
-> Map PackageName (Set PackageName, a)
forall a (f :: * -> *).
(Eq a, Foldable f) =>
f PackageName
-> Map PackageName (Set PackageName, a)
-> Map PackageName (Set PackageName, a)
pruneUnreachable f PackageName
dontPrune (Map PackageName (Set PackageName, a)
 -> Map PackageName (Set PackageName, a))
-> (Map PackageName (Set PackageName, a)
    -> Map PackageName (Set PackageName, a))
-> Map PackageName (Set PackageName, a)
-> Map PackageName (Set PackageName, a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PackageName -> (Set PackageName, a) -> Maybe (Set PackageName, a))
-> Map PackageName (Set PackageName, a)
-> Map PackageName (Set PackageName, a)
forall k a b. (k -> a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybeWithKey (\PackageName
pkg (Set PackageName
pkgDeps,a
x) ->
    if PackageName
pkg PackageName -> g PackageName -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`F.elem` g PackageName
names
      then Maybe (Set PackageName, a)
forall a. Maybe a
Nothing
      else let filtered :: Set PackageName
filtered = (PackageName -> Bool) -> Set PackageName -> Set PackageName
forall a. (a -> Bool) -> Set a -> Set a
Set.filter (\PackageName
n -> PackageName
n PackageName -> g PackageName -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`F.notElem` g PackageName
names) Set PackageName
pkgDeps
           in if Set PackageName -> Bool
forall a. Set a -> Bool
Set.null Set PackageName
filtered Bool -> Bool -> Bool
&& Bool -> Bool
not (Set PackageName -> Bool
forall a. Set a -> Bool
Set.null Set PackageName
pkgDeps)
                then Maybe (Set PackageName, a)
forall a. Maybe a
Nothing
                else (Set PackageName, a) -> Maybe (Set PackageName, a)
forall a. a -> Maybe a
Just (Set PackageName
filtered,a
x))

-- | Make sure that all unreachable nodes (orphans) are pruned
pruneUnreachable :: (Eq a, F.Foldable f)
                 => f PackageName
                 -> Map PackageName (Set PackageName, a)
                 -> Map PackageName (Set PackageName, a)
pruneUnreachable :: f PackageName
-> Map PackageName (Set PackageName, a)
-> Map PackageName (Set PackageName, a)
pruneUnreachable f PackageName
dontPrune = (Map PackageName (Set PackageName, a)
 -> Map PackageName (Set PackageName, a))
-> Map PackageName (Set PackageName, a)
-> Map PackageName (Set PackageName, a)
forall a. Eq a => (a -> a) -> a -> a
fixpoint Map PackageName (Set PackageName, a)
-> Map PackageName (Set PackageName, a)
forall b.
Map PackageName (Set PackageName, b)
-> Map PackageName (Set PackageName, b)
prune
  where fixpoint :: Eq a => (a -> a) -> a -> a
        fixpoint :: (a -> a) -> a -> a
fixpoint a -> a
f a
v = if a -> a
f a
v a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
v then a
v else (a -> a) -> a -> a
forall a. Eq a => (a -> a) -> a -> a
fixpoint a -> a
f (a -> a
f a
v)
        prune :: Map PackageName (Set PackageName, b)
-> Map PackageName (Set PackageName, b)
prune Map PackageName (Set PackageName, b)
graph' = (PackageName -> (Set PackageName, b) -> Bool)
-> Map PackageName (Set PackageName, b)
-> Map PackageName (Set PackageName, b)
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey (\PackageName
k (Set PackageName, b)
_ -> PackageName -> Bool
reachable PackageName
k) Map PackageName (Set PackageName, b)
graph'
          where reachable :: PackageName -> Bool
reachable PackageName
k = PackageName
k PackageName -> f PackageName -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`F.elem` f PackageName
dontPrune Bool -> Bool -> Bool
|| PackageName
k PackageName -> Set PackageName -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set PackageName
reachables
                reachables :: Set PackageName
reachables = Map PackageName (Set PackageName) -> Set PackageName
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
F.fold ((Set PackageName, b) -> Set PackageName
forall a b. (a, b) -> a
fst ((Set PackageName, b) -> Set PackageName)
-> Map PackageName (Set PackageName, b)
-> Map PackageName (Set PackageName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map PackageName (Set PackageName, b)
graph')


-- | Resolve the dependency graph up to (Just depth) or until fixpoint is reached
resolveDependencies :: (Applicative m, Monad m)
                    => Maybe Int
                    -> Map PackageName (Set PackageName, DotPayload)
                    -> (PackageName -> m (Set PackageName, DotPayload))
                    -> m (Map PackageName (Set PackageName, DotPayload))
resolveDependencies :: Maybe Int
-> Map PackageName (Set PackageName, DotPayload)
-> (PackageName -> m (Set PackageName, DotPayload))
-> m (Map PackageName (Set PackageName, DotPayload))
resolveDependencies (Just Int
0) Map PackageName (Set PackageName, DotPayload)
graph PackageName -> m (Set PackageName, DotPayload)
_ = Map PackageName (Set PackageName, DotPayload)
-> m (Map PackageName (Set PackageName, DotPayload))
forall (m :: * -> *) a. Monad m => a -> m a
return Map PackageName (Set PackageName, DotPayload)
graph
resolveDependencies Maybe Int
limit Map PackageName (Set PackageName, DotPayload)
graph PackageName -> m (Set PackageName, DotPayload)
loadPackageDeps = do
  let values :: Set PackageName
values = [Set PackageName] -> Set PackageName
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions ((Set PackageName, DotPayload) -> Set PackageName
forall a b. (a, b) -> a
fst ((Set PackageName, DotPayload) -> Set PackageName)
-> [(Set PackageName, DotPayload)] -> [Set PackageName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map PackageName (Set PackageName, DotPayload)
-> [(Set PackageName, DotPayload)]
forall k a. Map k a -> [a]
Map.elems Map PackageName (Set PackageName, DotPayload)
graph)
      keys :: Set PackageName
keys = Map PackageName (Set PackageName, DotPayload) -> Set PackageName
forall k a. Map k a -> Set k
Map.keysSet Map PackageName (Set PackageName, DotPayload)
graph
      next :: Set PackageName
next = Set PackageName -> Set PackageName -> Set PackageName
forall a. Ord a => Set a -> Set a -> Set a
Set.difference Set PackageName
values Set PackageName
keys
  if Set PackageName -> Bool
forall a. Set a -> Bool
Set.null Set PackageName
next
     then Map PackageName (Set PackageName, DotPayload)
-> m (Map PackageName (Set PackageName, DotPayload))
forall (m :: * -> *) a. Monad m => a -> m a
return Map PackageName (Set PackageName, DotPayload)
graph
     else do
       [(PackageName, (Set PackageName, DotPayload))]
x <- (PackageName -> m (PackageName, (Set PackageName, DotPayload)))
-> [PackageName]
-> m [(PackageName, (Set PackageName, DotPayload))]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
T.traverse (\PackageName
name -> (PackageName
name,) ((Set PackageName, DotPayload)
 -> (PackageName, (Set PackageName, DotPayload)))
-> m (Set PackageName, DotPayload)
-> m (PackageName, (Set PackageName, DotPayload))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PackageName -> m (Set PackageName, DotPayload)
loadPackageDeps PackageName
name) (Set PackageName -> [PackageName]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList Set PackageName
next)
       Maybe Int
-> Map PackageName (Set PackageName, DotPayload)
-> (PackageName -> m (Set PackageName, DotPayload))
-> m (Map PackageName (Set PackageName, DotPayload))
forall (m :: * -> *).
(Applicative m, Monad m) =>
Maybe Int
-> Map PackageName (Set PackageName, DotPayload)
-> (PackageName -> m (Set PackageName, DotPayload))
-> m (Map PackageName (Set PackageName, DotPayload))
resolveDependencies (Int -> Int -> Int
forall a. Num a => a -> a -> a
subtract Int
1 (Int -> Int) -> Maybe Int -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Int
limit)
                      (((Set PackageName, DotPayload)
 -> (Set PackageName, DotPayload) -> (Set PackageName, DotPayload))
-> Map PackageName (Set PackageName, DotPayload)
-> Map PackageName (Set PackageName, DotPayload)
-> Map PackageName (Set PackageName, DotPayload)
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith (Set PackageName, DotPayload)
-> (Set PackageName, DotPayload) -> (Set PackageName, DotPayload)
forall a b b. Ord a => (Set a, b) -> (Set a, b) -> (Set a, b)
unifier Map PackageName (Set PackageName, DotPayload)
graph ([(PackageName, (Set PackageName, DotPayload))]
-> Map PackageName (Set PackageName, DotPayload)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(PackageName, (Set PackageName, DotPayload))]
x))
                      PackageName -> m (Set PackageName, DotPayload)
loadPackageDeps
  where unifier :: (Set a, b) -> (Set a, b) -> (Set a, b)
unifier (Set a
pkgs1,b
v1) (Set a
pkgs2,b
_) = (Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set a
pkgs1 Set a
pkgs2, b
v1)

-- | Given a SourceMap and a dependency loader, load the set of dependencies for a package
createDepLoader :: SourceMap
                -> Map PackageName DumpPackage
                -> Map GhcPkgId PackageIdentifier
                -> (PackageName -> Version -> PackageLocationImmutable ->
                    Map FlagName Bool -> [Text] -> [Text] -> RIO DotConfig (Set PackageName, DotPayload))
                -> PackageName
                -> RIO DotConfig (Set PackageName, DotPayload)
createDepLoader :: SourceMap
-> Map PackageName DumpPackage
-> Map GhcPkgId PackageIdentifier
-> (PackageName
    -> Version
    -> PackageLocationImmutable
    -> Map FlagName Bool
    -> [Text]
    -> [Text]
    -> RIO DotConfig (Set PackageName, DotPayload))
-> PackageName
-> RIO DotConfig (Set PackageName, DotPayload)
createDepLoader SourceMap
sourceMap Map PackageName DumpPackage
globalDumpMap Map GhcPkgId PackageIdentifier
globalIdMap PackageName
-> Version
-> PackageLocationImmutable
-> Map FlagName Bool
-> [Text]
-> [Text]
-> RIO DotConfig (Set PackageName, DotPayload)
loadPackageDeps PackageName
pkgName = do
  RIO DotConfig (Set PackageName, DotPayload)
-> Maybe (RIO DotConfig (Set PackageName, DotPayload))
-> RIO DotConfig (Set PackageName, DotPayload)
forall a. a -> Maybe a -> a
fromMaybe RIO DotConfig (Set PackageName, DotPayload)
forall a. a
noDepsErr
    (Maybe (RIO DotConfig (Set PackageName, DotPayload))
projectPackageDeps Maybe (RIO DotConfig (Set PackageName, DotPayload))
-> Maybe (RIO DotConfig (Set PackageName, DotPayload))
-> Maybe (RIO DotConfig (Set PackageName, DotPayload))
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe (RIO DotConfig (Set PackageName, DotPayload))
dependencyDeps Maybe (RIO DotConfig (Set PackageName, DotPayload))
-> Maybe (RIO DotConfig (Set PackageName, DotPayload))
-> Maybe (RIO DotConfig (Set PackageName, DotPayload))
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe (RIO DotConfig (Set PackageName, DotPayload))
globalDeps)
  where
    projectPackageDeps :: Maybe (RIO DotConfig (Set PackageName, DotPayload))
projectPackageDeps =
      ProjectPackage -> RIO DotConfig (Set PackageName, DotPayload)
forall env.
(HasBuildConfig env, HasSourceMap env) =>
ProjectPackage -> RIO env (Set PackageName, DotPayload)
loadDeps (ProjectPackage -> RIO DotConfig (Set PackageName, DotPayload))
-> Maybe ProjectPackage
-> Maybe (RIO DotConfig (Set PackageName, DotPayload))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PackageName
-> Map PackageName ProjectPackage -> Maybe ProjectPackage
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
pkgName (SourceMap -> Map PackageName ProjectPackage
smProject SourceMap
sourceMap)
      where
        loadDeps :: ProjectPackage -> RIO env (Set PackageName, DotPayload)
loadDeps ProjectPackage
pp = do
          Package
pkg <- CommonPackage -> RIO env Package
forall env.
(HasBuildConfig env, HasSourceMap env) =>
CommonPackage -> RIO env Package
loadCommonPackage (ProjectPackage -> CommonPackage
ppCommon ProjectPackage
pp)
          (Set PackageName, DotPayload)
-> RIO env (Set PackageName, DotPayload)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Package -> Set PackageName
packageAllDeps Package
pkg, Package -> Maybe PackageLocation -> DotPayload
payloadFromLocal Package
pkg Maybe PackageLocation
forall a. Maybe a
Nothing)

    dependencyDeps :: Maybe (RIO DotConfig (Set PackageName, DotPayload))
dependencyDeps =
      DepPackage -> RIO DotConfig (Set PackageName, DotPayload)
loadDeps (DepPackage -> RIO DotConfig (Set PackageName, DotPayload))
-> Maybe DepPackage
-> Maybe (RIO DotConfig (Set PackageName, DotPayload))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PackageName -> Map PackageName DepPackage -> Maybe DepPackage
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
pkgName (SourceMap -> Map PackageName DepPackage
smDeps SourceMap
sourceMap)
      where
        loadDeps :: DepPackage -> RIO DotConfig (Set PackageName, DotPayload)
loadDeps DepPackage{dpLocation :: DepPackage -> PackageLocation
dpLocation=PLMutable ResolvedPath Dir
dir} = do
              ProjectPackage
pp <- PrintWarnings
-> ResolvedPath Dir -> Bool -> RIO DotConfig ProjectPackage
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
PrintWarnings -> ResolvedPath Dir -> Bool -> RIO env ProjectPackage
mkProjectPackage PrintWarnings
YesPrintWarnings ResolvedPath Dir
dir Bool
False
              Package
pkg <- CommonPackage -> RIO DotConfig Package
forall env.
(HasBuildConfig env, HasSourceMap env) =>
CommonPackage -> RIO env Package
loadCommonPackage (ProjectPackage -> CommonPackage
ppCommon ProjectPackage
pp)
              (Set PackageName, DotPayload)
-> RIO DotConfig (Set PackageName, DotPayload)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Package -> Set PackageName
packageAllDeps Package
pkg, Package -> Maybe PackageLocation -> DotPayload
payloadFromLocal Package
pkg (PackageLocation -> Maybe PackageLocation
forall a. a -> Maybe a
Just (PackageLocation -> Maybe PackageLocation)
-> PackageLocation -> Maybe PackageLocation
forall a b. (a -> b) -> a -> b
$ ResolvedPath Dir -> PackageLocation
PLMutable ResolvedPath Dir
dir))

        loadDeps dp :: DepPackage
dp@DepPackage{dpLocation :: DepPackage -> PackageLocation
dpLocation=PLImmutable PackageLocationImmutable
loc} = do
          let common :: CommonPackage
common = DepPackage -> CommonPackage
dpCommon DepPackage
dp
          GenericPackageDescription
gpd <- IO GenericPackageDescription
-> RIO DotConfig GenericPackageDescription
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO GenericPackageDescription
 -> RIO DotConfig GenericPackageDescription)
-> IO GenericPackageDescription
-> RIO DotConfig GenericPackageDescription
forall a b. (a -> b) -> a -> b
$ CommonPackage -> IO GenericPackageDescription
cpGPD CommonPackage
common
          let PackageIdentifier PackageName
name Version
version = PackageDescription -> PackageIdentifier
PD.package (PackageDescription -> PackageIdentifier)
-> PackageDescription -> PackageIdentifier
forall a b. (a -> b) -> a -> b
$ GenericPackageDescription -> PackageDescription
PD.packageDescription GenericPackageDescription
gpd
              flags :: Map FlagName Bool
flags = CommonPackage -> Map FlagName Bool
cpFlags CommonPackage
common
              ghcOptions :: [Text]
ghcOptions = CommonPackage -> [Text]
cpGhcOptions CommonPackage
common
              cabalConfigOpts :: [Text]
cabalConfigOpts = CommonPackage -> [Text]
cpCabalConfigOpts CommonPackage
common
          Bool
-> RIO DotConfig (Set PackageName, DotPayload)
-> RIO DotConfig (Set PackageName, DotPayload)
forall a. HasCallStack => Bool -> a -> a
assert (PackageName
pkgName PackageName -> PackageName -> Bool
forall a. Eq a => a -> a -> Bool
== PackageName
name) (PackageName
-> Version
-> PackageLocationImmutable
-> Map FlagName Bool
-> [Text]
-> [Text]
-> RIO DotConfig (Set PackageName, DotPayload)
loadPackageDeps PackageName
pkgName Version
version PackageLocationImmutable
loc Map FlagName Bool
flags [Text]
ghcOptions [Text]
cabalConfigOpts)

    -- If package is a global package, use info from ghc-pkg (#4324, #3084)
    globalDeps :: Maybe (RIO DotConfig (Set PackageName, DotPayload))
globalDeps =
      (Set PackageName, DotPayload)
-> RIO DotConfig (Set PackageName, DotPayload)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Set PackageName, DotPayload)
 -> RIO DotConfig (Set PackageName, DotPayload))
-> (DumpPackage -> (Set PackageName, DotPayload))
-> DumpPackage
-> RIO DotConfig (Set PackageName, DotPayload)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DumpPackage -> (Set PackageName, DotPayload)
getDepsFromDump (DumpPackage -> RIO DotConfig (Set PackageName, DotPayload))
-> Maybe DumpPackage
-> Maybe (RIO DotConfig (Set PackageName, DotPayload))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PackageName -> Map PackageName DumpPackage -> Maybe DumpPackage
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
pkgName Map PackageName DumpPackage
globalDumpMap
      where
        getDepsFromDump :: DumpPackage -> (Set PackageName, DotPayload)
getDepsFromDump DumpPackage
dump =
          ([PackageName] -> Set PackageName
forall a. Ord a => [a] -> Set a
Set.fromList [PackageName]
deps, DumpPackage -> DotPayload
payloadFromDump DumpPackage
dump)
          where
            deps :: [PackageName]
deps = (GhcPkgId -> PackageName) -> [GhcPkgId] -> [PackageName]
forall a b. (a -> b) -> [a] -> [b]
map GhcPkgId -> PackageName
ghcIdToPackageName (DumpPackage -> [GhcPkgId]
dpDepends DumpPackage
dump)
            ghcIdToPackageName :: GhcPkgId -> PackageName
ghcIdToPackageName GhcPkgId
depId =
              let errText :: String
errText = String
"Invariant violated: Expected to find "
              in PackageName
-> (PackageIdentifier -> PackageName)
-> Maybe PackageIdentifier
-> PackageName
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> PackageName
forall a. HasCallStack => String -> a
error (String
errText String -> ShowS
forall a. [a] -> [a] -> [a]
++ GhcPkgId -> String
ghcPkgIdString GhcPkgId
depId String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" in global DB"))
                 PackageIdentifier -> PackageName
Stack.Prelude.pkgName
                 (GhcPkgId
-> Map GhcPkgId PackageIdentifier -> Maybe PackageIdentifier
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup GhcPkgId
depId Map GhcPkgId PackageIdentifier
globalIdMap)

    noDepsErr :: a
noDepsErr = String -> a
forall a. HasCallStack => String -> a
error (String
"Invariant violated: The '" String -> ShowS
forall a. [a] -> [a] -> [a]
++ PackageName -> String
packageNameString PackageName
pkgName
                String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"' package was not found in any of the dependency sources")

    payloadFromLocal :: Package -> Maybe PackageLocation -> DotPayload
payloadFromLocal Package
pkg Maybe PackageLocation
loc = Maybe Version
-> Maybe (Either License License)
-> Maybe PackageLocation
-> DotPayload
DotPayload (Version -> Maybe Version
forall a. a -> Maybe a
Just (Version -> Maybe Version) -> Version -> Maybe Version
forall a b. (a -> b) -> a -> b
$ Package -> Version
packageVersion Package
pkg) (Either License License -> Maybe (Either License License)
forall a. a -> Maybe a
Just (Either License License -> Maybe (Either License License))
-> Either License License -> Maybe (Either License License)
forall a b. (a -> b) -> a -> b
$ Package -> Either License License
packageLicense Package
pkg) Maybe PackageLocation
loc
    payloadFromDump :: DumpPackage -> DotPayload
payloadFromDump DumpPackage
dp = Maybe Version
-> Maybe (Either License License)
-> Maybe PackageLocation
-> DotPayload
DotPayload (Version -> Maybe Version
forall a. a -> Maybe a
Just (Version -> Maybe Version) -> Version -> Maybe Version
forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> Version
pkgVersion (PackageIdentifier -> Version) -> PackageIdentifier -> Version
forall a b. (a -> b) -> a -> b
$ DumpPackage -> PackageIdentifier
dpPackageIdent DumpPackage
dp) (License -> Either License License
forall a b. b -> Either a b
Right (License -> Either License License)
-> Maybe License -> Maybe (Either License License)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DumpPackage -> Maybe License
dpLicense DumpPackage
dp) Maybe PackageLocation
forall a. Maybe a
Nothing

-- | Resolve the direct (depth 0) external dependencies of the given local packages (assumed to come from project packages)
projectPackageDependencies :: DotOpts -> [LocalPackage] -> [(PackageName, (Set PackageName, DotPayload))]
projectPackageDependencies :: DotOpts
-> [LocalPackage] -> [(PackageName, (Set PackageName, DotPayload))]
projectPackageDependencies DotOpts
dotOpts [LocalPackage]
locals =
    (LocalPackage -> (PackageName, (Set PackageName, DotPayload)))
-> [LocalPackage] -> [(PackageName, (Set PackageName, DotPayload))]
forall a b. (a -> b) -> [a] -> [b]
map (\LocalPackage
lp -> let pkg :: Package
pkg = LocalPackage -> Package
localPackageToPackage LocalPackage
lp
                    pkgDir :: Path Abs Dir
pkgDir = Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
Path.parent (Path Abs File -> Path Abs Dir) -> Path Abs File -> Path Abs Dir
forall a b. (a -> b) -> a -> b
$ LocalPackage -> Path Abs File
lpCabalFile LocalPackage
lp
                    loc :: PackageLocation
loc = ResolvedPath Dir -> PackageLocation
PLMutable (ResolvedPath Dir -> PackageLocation)
-> ResolvedPath Dir -> PackageLocation
forall a b. (a -> b) -> a -> b
$ RelFilePath -> Path Abs Dir -> ResolvedPath Dir
forall t. RelFilePath -> Path Abs t -> ResolvedPath t
ResolvedPath (Text -> RelFilePath
RelFilePath Text
"N/A") Path Abs Dir
pkgDir
                 in (Package -> PackageName
packageName Package
pkg, (Package -> Set PackageName
deps Package
pkg, Package -> PackageLocation -> DotPayload
lpPayload Package
pkg PackageLocation
loc)))
        [LocalPackage]
locals
  where deps :: Package -> Set PackageName
deps Package
pkg =
          if DotOpts -> Bool
dotIncludeExternal DotOpts
dotOpts
            then PackageName -> Set PackageName -> Set PackageName
forall a. Ord a => a -> Set a -> Set a
Set.delete (Package -> PackageName
packageName Package
pkg) (Package -> Set PackageName
packageAllDeps Package
pkg)
            else Set PackageName -> Set PackageName -> Set PackageName
forall a. Ord a => Set a -> Set a -> Set a
Set.intersection Set PackageName
localNames (Package -> Set PackageName
packageAllDeps Package
pkg)
        localNames :: Set PackageName
localNames = [PackageName] -> Set PackageName
forall a. Ord a => [a] -> Set a
Set.fromList ([PackageName] -> Set PackageName)
-> [PackageName] -> Set PackageName
forall a b. (a -> b) -> a -> b
$ (LocalPackage -> PackageName) -> [LocalPackage] -> [PackageName]
forall a b. (a -> b) -> [a] -> [b]
map (Package -> PackageName
packageName (Package -> PackageName)
-> (LocalPackage -> Package) -> LocalPackage -> PackageName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocalPackage -> Package
lpPackage) [LocalPackage]
locals
        lpPayload :: Package -> PackageLocation -> DotPayload
lpPayload Package
pkg PackageLocation
loc = Maybe Version
-> Maybe (Either License License)
-> Maybe PackageLocation
-> DotPayload
DotPayload (Version -> Maybe Version
forall a. a -> Maybe a
Just (Version -> Maybe Version) -> Version -> Maybe Version
forall a b. (a -> b) -> a -> b
$ Package -> Version
packageVersion Package
pkg) (Either License License -> Maybe (Either License License)
forall a. a -> Maybe a
Just (Either License License -> Maybe (Either License License))
-> Either License License -> Maybe (Either License License)
forall a b. (a -> b) -> a -> b
$ Package -> Either License License
packageLicense Package
pkg) (PackageLocation -> Maybe PackageLocation
forall a. a -> Maybe a
Just PackageLocation
loc)

-- | Print a graphviz graph of the edges in the Map and highlight the given local packages
printGraph :: (Applicative m, MonadIO m)
           => DotOpts
           -> Set PackageName -- ^ all locals
           -> Map PackageName (Set PackageName, DotPayload)
           -> m ()
printGraph :: DotOpts
-> Set PackageName
-> Map PackageName (Set PackageName, DotPayload)
-> m ()
printGraph DotOpts
dotOpts Set PackageName
locals Map PackageName (Set PackageName, DotPayload)
graph = do
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
Text.putStrLn Text
"strict digraph deps {"
  DotOpts -> Set PackageName -> m ()
forall (t :: * -> *) (m :: * -> *).
(Foldable t, MonadIO m) =>
DotOpts -> t PackageName -> m ()
printLocalNodes DotOpts
dotOpts Set PackageName
filteredLocals
  Map PackageName (Set PackageName, DotPayload) -> m ()
forall (m :: * -> *).
MonadIO m =>
Map PackageName (Set PackageName, DotPayload) -> m ()
printLeaves Map PackageName (Set PackageName, DotPayload)
graph
  m (Map PackageName ()) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ((PackageName -> Set PackageName -> m ())
-> Map PackageName (Set PackageName) -> m (Map PackageName ())
forall (t :: * -> *) k a b.
Applicative t =>
(k -> a -> t b) -> Map k a -> t (Map k b)
Map.traverseWithKey PackageName -> Set PackageName -> m ()
forall (m :: * -> *).
MonadIO m =>
PackageName -> Set PackageName -> m ()
printEdges ((Set PackageName, DotPayload) -> Set PackageName
forall a b. (a, b) -> a
fst ((Set PackageName, DotPayload) -> Set PackageName)
-> Map PackageName (Set PackageName, DotPayload)
-> Map PackageName (Set PackageName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map PackageName (Set PackageName, DotPayload)
graph))
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
Text.putStrLn Text
"}"
  where filteredLocals :: Set PackageName
filteredLocals = (PackageName -> Bool) -> Set PackageName -> Set PackageName
forall a. (a -> Bool) -> Set a -> Set a
Set.filter (\PackageName
local' ->
          PackageName
local' PackageName -> Set PackageName -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` DotOpts -> Set PackageName
dotPrune DotOpts
dotOpts) Set PackageName
locals

-- | Print the local nodes with a different style depending on options
printLocalNodes :: (F.Foldable t, MonadIO m)
                => DotOpts
                -> t PackageName
                -> m ()
printLocalNodes :: DotOpts -> t PackageName -> m ()
printLocalNodes DotOpts
dotOpts t PackageName
locals = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
Text.putStrLn (Text -> [Text] -> Text
Text.intercalate Text
"\n" [Text]
lpNodes)
  where applyStyle :: Text -> Text
        applyStyle :: Text -> Text
applyStyle Text
n = if DotOpts -> Bool
dotIncludeExternal DotOpts
dotOpts
                         then Text
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" [style=dashed];"
                         else Text
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" [style=solid];"
        lpNodes :: [Text]
        lpNodes :: [Text]
lpNodes = (PackageName -> Text) -> [PackageName] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Text
applyStyle (Text -> Text) -> (PackageName -> Text) -> PackageName -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> Text
nodeName) (t PackageName -> [PackageName]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList t PackageName
locals)

-- | Print nodes without dependencies
printLeaves :: MonadIO m
            => Map PackageName (Set PackageName, DotPayload)
            -> m ()
printLeaves :: Map PackageName (Set PackageName, DotPayload) -> m ()
printLeaves = (PackageName -> m ()) -> Set PackageName -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
F.mapM_ PackageName -> m ()
forall (m :: * -> *). MonadIO m => PackageName -> m ()
printLeaf (Set PackageName -> m ())
-> (Map PackageName (Set PackageName, DotPayload)
    -> Set PackageName)
-> Map PackageName (Set PackageName, DotPayload)
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map PackageName (Set PackageName) -> Set PackageName
forall k a. Map k a -> Set k
Map.keysSet (Map PackageName (Set PackageName) -> Set PackageName)
-> (Map PackageName (Set PackageName, DotPayload)
    -> Map PackageName (Set PackageName))
-> Map PackageName (Set PackageName, DotPayload)
-> Set PackageName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set PackageName -> Bool)
-> Map PackageName (Set PackageName)
-> Map PackageName (Set PackageName)
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter Set PackageName -> Bool
forall a. Set a -> Bool
Set.null (Map PackageName (Set PackageName)
 -> Map PackageName (Set PackageName))
-> (Map PackageName (Set PackageName, DotPayload)
    -> Map PackageName (Set PackageName))
-> Map PackageName (Set PackageName, DotPayload)
-> Map PackageName (Set PackageName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Set PackageName, DotPayload) -> Set PackageName)
-> Map PackageName (Set PackageName, DotPayload)
-> Map PackageName (Set PackageName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Set PackageName, DotPayload) -> Set PackageName
forall a b. (a, b) -> a
fst

-- | @printDedges p ps@ prints an edge from p to every ps
printEdges :: MonadIO m => PackageName -> Set PackageName -> m ()
printEdges :: PackageName -> Set PackageName -> m ()
printEdges PackageName
package Set PackageName
deps = Set PackageName -> (PackageName -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
F.forM_ Set PackageName
deps (PackageName -> PackageName -> m ()
forall (m :: * -> *).
MonadIO m =>
PackageName -> PackageName -> m ()
printEdge PackageName
package)

-- | Print an edge between the two package names
printEdge :: MonadIO m => PackageName -> PackageName -> m ()
printEdge :: PackageName -> PackageName -> m ()
printEdge PackageName
from PackageName
to' = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
Text.putStrLn ([Text] -> Text
Text.concat [ PackageName -> Text
nodeName PackageName
from, Text
" -> ", PackageName -> Text
nodeName PackageName
to', Text
";"])

-- | Convert a package name to a graph node name.
nodeName :: PackageName -> Text
nodeName :: PackageName -> Text
nodeName PackageName
name = Text
"\"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (PackageName -> String
packageNameString PackageName
name) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\""

-- | Print a node with no dependencies
printLeaf :: MonadIO m => PackageName -> m ()
printLeaf :: PackageName -> m ()
printLeaf PackageName
package = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> ([Text] -> IO ()) -> [Text] -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> IO ()
Text.putStrLn (Text -> IO ()) -> ([Text] -> Text) -> [Text] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
Text.concat ([Text] -> m ()) -> [Text] -> m ()
forall a b. (a -> b) -> a -> b
$
  if PackageName -> Bool
isWiredIn PackageName
package
    then [Text
"{rank=max; ", PackageName -> Text
nodeName PackageName
package, Text
" [shape=box]; };"]
    else [Text
"{rank=max; ", PackageName -> Text
nodeName PackageName
package, Text
"; };"]

-- | Check if the package is wired in (shipped with) ghc
isWiredIn :: PackageName -> Bool
isWiredIn :: PackageName -> Bool
isWiredIn = (PackageName -> Set PackageName -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set PackageName
wiredInPackages)

localPackageToPackage :: LocalPackage -> Package
localPackageToPackage :: LocalPackage -> Package
localPackageToPackage LocalPackage
lp =
  Package -> Maybe Package -> Package
forall a. a -> Maybe a -> a
fromMaybe (LocalPackage -> Package
lpPackage LocalPackage
lp) (LocalPackage -> Maybe Package
lpTestBench LocalPackage
lp)

-- Plumbing for --test and --bench flags
withDotConfig
    :: DotOpts
    -> RIO DotConfig a
    -> RIO Runner a
withDotConfig :: DotOpts -> RIO DotConfig a -> RIO Runner a
withDotConfig DotOpts
opts RIO DotConfig a
inner =
  (Runner -> Runner) -> RIO Runner a -> RIO Runner a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (ASetter Runner Runner GlobalOpts GlobalOpts
-> (GlobalOpts -> GlobalOpts) -> Runner -> Runner
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter Runner Runner GlobalOpts GlobalOpts
forall env. HasRunner env => Lens' env GlobalOpts
globalOptsL GlobalOpts -> GlobalOpts
modifyGO) (RIO Runner a -> RIO Runner a) -> RIO Runner a -> RIO Runner a
forall a b. (a -> b) -> a -> b
$
    if DotOpts -> Bool
dotGlobalHints DotOpts
opts
      then ShouldReexec -> RIO Config a -> RIO Runner a
forall a. ShouldReexec -> RIO Config a -> RIO Runner a
withConfig ShouldReexec
NoReexec (RIO Config a -> RIO Runner a) -> RIO Config a -> RIO Runner a
forall a b. (a -> b) -> a -> b
$ RIO BuildConfig a -> RIO Config a
forall a. RIO BuildConfig a -> RIO Config a
withBuildConfig RIO BuildConfig a
withGlobalHints
      else ShouldReexec -> RIO Config a -> RIO Runner a
forall a. ShouldReexec -> RIO Config a -> RIO Runner a
withConfig ShouldReexec
YesReexec RIO Config a
withReal
  where
    withGlobalHints :: RIO BuildConfig a
withGlobalHints = do
      BuildConfig
bconfig <- Getting BuildConfig BuildConfig BuildConfig
-> RIO BuildConfig BuildConfig
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting BuildConfig BuildConfig BuildConfig
forall env. HasBuildConfig env => Lens' env BuildConfig
buildConfigL
      Map PackageName Version
globals <- WantedCompiler -> RIO BuildConfig (Map PackageName Version)
forall env.
HasConfig env =>
WantedCompiler -> RIO env (Map PackageName Version)
globalsFromHints (WantedCompiler -> RIO BuildConfig (Map PackageName Version))
-> WantedCompiler -> RIO BuildConfig (Map PackageName Version)
forall a b. (a -> b) -> a -> b
$ SMWanted -> WantedCompiler
smwCompiler (SMWanted -> WantedCompiler) -> SMWanted -> WantedCompiler
forall a b. (a -> b) -> a -> b
$ BuildConfig -> SMWanted
bcSMWanted BuildConfig
bconfig
      GhcPkgId
fakeGhcPkgId <- Text -> RIO BuildConfig GhcPkgId
forall (m :: * -> *). MonadThrow m => Text -> m GhcPkgId
parseGhcPkgId Text
"ignored"
      ActualCompiler
actual <- (CompilerException -> RIO BuildConfig ActualCompiler)
-> (ActualCompiler -> RIO BuildConfig ActualCompiler)
-> Either CompilerException ActualCompiler
-> RIO BuildConfig ActualCompiler
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either CompilerException -> RIO BuildConfig ActualCompiler
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO ActualCompiler -> RIO BuildConfig ActualCompiler
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either CompilerException ActualCompiler
 -> RIO BuildConfig ActualCompiler)
-> Either CompilerException ActualCompiler
-> RIO BuildConfig ActualCompiler
forall a b. (a -> b) -> a -> b
$
                WantedCompiler -> Either CompilerException ActualCompiler
wantedToActual (WantedCompiler -> Either CompilerException ActualCompiler)
-> WantedCompiler -> Either CompilerException ActualCompiler
forall a b. (a -> b) -> a -> b
$ SMWanted -> WantedCompiler
smwCompiler (SMWanted -> WantedCompiler) -> SMWanted -> WantedCompiler
forall a b. (a -> b) -> a -> b
$
                BuildConfig -> SMWanted
bcSMWanted BuildConfig
bconfig
      let smActual :: SMActual DumpPackage
smActual = SMActual :: forall global.
ActualCompiler
-> Map PackageName ProjectPackage
-> Map PackageName DepPackage
-> Map PackageName global
-> SMActual global
SMActual
            { smaCompiler :: ActualCompiler
smaCompiler = ActualCompiler
actual
            , smaProject :: Map PackageName ProjectPackage
smaProject = SMWanted -> Map PackageName ProjectPackage
smwProject (SMWanted -> Map PackageName ProjectPackage)
-> SMWanted -> Map PackageName ProjectPackage
forall a b. (a -> b) -> a -> b
$ BuildConfig -> SMWanted
bcSMWanted BuildConfig
bconfig
            , smaDeps :: Map PackageName DepPackage
smaDeps = SMWanted -> Map PackageName DepPackage
smwDeps (SMWanted -> Map PackageName DepPackage)
-> SMWanted -> Map PackageName DepPackage
forall a b. (a -> b) -> a -> b
$ BuildConfig -> SMWanted
bcSMWanted BuildConfig
bconfig
            , smaGlobal :: Map PackageName DumpPackage
smaGlobal = (PackageName -> Version -> DumpPackage)
-> Map PackageName Version -> Map PackageName DumpPackage
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey PackageName -> Version -> DumpPackage
toDump Map PackageName Version
globals
            }
          toDump :: PackageName -> Version -> DumpPackage
          toDump :: PackageName -> Version -> DumpPackage
toDump PackageName
name Version
version = DumpPackage :: GhcPkgId
-> PackageIdentifier
-> Maybe PackageIdentifier
-> Maybe License
-> [String]
-> [Text]
-> Bool
-> Set ModuleName
-> [GhcPkgId]
-> [String]
-> Maybe String
-> Bool
-> DumpPackage
DumpPackage
            { dpGhcPkgId :: GhcPkgId
dpGhcPkgId = GhcPkgId
fakeGhcPkgId
            , dpPackageIdent :: PackageIdentifier
dpPackageIdent = PackageName -> Version -> PackageIdentifier
PackageIdentifier PackageName
name Version
version
            , dpParentLibIdent :: Maybe PackageIdentifier
dpParentLibIdent = Maybe PackageIdentifier
forall a. Maybe a
Nothing
            , dpLicense :: Maybe License
dpLicense = Maybe License
forall a. Maybe a
Nothing
            , dpLibDirs :: [String]
dpLibDirs = []
            , dpLibraries :: [Text]
dpLibraries = []
            , dpHasExposedModules :: Bool
dpHasExposedModules = Bool
True
            , dpExposedModules :: Set ModuleName
dpExposedModules = Set ModuleName
forall a. Monoid a => a
mempty
            , dpDepends :: [GhcPkgId]
dpDepends = []
            , dpHaddockInterfaces :: [String]
dpHaddockInterfaces = []
            , dpHaddockHtml :: Maybe String
dpHaddockHtml = Maybe String
forall a. Maybe a
Nothing
            , dpIsExposed :: Bool
dpIsExposed = Bool
True
            }
          actualPkgs :: Set PackageName
actualPkgs = Map PackageName DepPackage -> Set PackageName
forall k a. Map k a -> Set k
Map.keysSet (SMActual DumpPackage -> Map PackageName DepPackage
forall global. SMActual global -> Map PackageName DepPackage
smaDeps SMActual DumpPackage
smActual) Set PackageName -> Set PackageName -> Set PackageName
forall a. Semigroup a => a -> a -> a
<>
                       Map PackageName ProjectPackage -> Set PackageName
forall k a. Map k a -> Set k
Map.keysSet (SMActual DumpPackage -> Map PackageName ProjectPackage
forall global. SMActual global -> Map PackageName ProjectPackage
smaProject SMActual DumpPackage
smActual)
          prunedActual :: SMActual GlobalPackage
prunedActual = SMActual DumpPackage
smActual { smaGlobal :: Map PackageName GlobalPackage
smaGlobal = Map PackageName DumpPackage
-> Set PackageName -> Map PackageName GlobalPackage
pruneGlobals (SMActual DumpPackage -> Map PackageName DumpPackage
forall global. SMActual global -> Map PackageName global
smaGlobal SMActual DumpPackage
smActual) Set PackageName
actualPkgs }
      SMTargets
targets <- NeedTargets
-> Bool
-> BuildOptsCLI
-> SMActual GlobalPackage
-> RIO BuildConfig SMTargets
forall env.
HasBuildConfig env =>
NeedTargets
-> Bool
-> BuildOptsCLI
-> SMActual GlobalPackage
-> RIO env SMTargets
parseTargets NeedTargets
NeedTargets Bool
False BuildOptsCLI
boptsCLI SMActual GlobalPackage
prunedActual
      Utf8Builder -> RIO BuildConfig ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Loading source map"
      SourceMap
sourceMap <- SMTargets
-> BuildOptsCLI
-> SMActual DumpPackage
-> RIO BuildConfig SourceMap
forall env.
HasBuildConfig env =>
SMTargets
-> BuildOptsCLI -> SMActual DumpPackage -> RIO env SourceMap
loadSourceMap SMTargets
targets BuildOptsCLI
boptsCLI SMActual DumpPackage
smActual
      let dc :: DotConfig
dc = DotConfig :: BuildConfig -> SourceMap -> [DumpPackage] -> DotConfig
DotConfig
                  { dcBuildConfig :: BuildConfig
dcBuildConfig = BuildConfig
bconfig
                  , dcSourceMap :: SourceMap
dcSourceMap = SourceMap
sourceMap
                  , dcGlobalDump :: [DumpPackage]
dcGlobalDump = Map PackageName DumpPackage -> [DumpPackage]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Map PackageName DumpPackage -> [DumpPackage])
-> Map PackageName DumpPackage -> [DumpPackage]
forall a b. (a -> b) -> a -> b
$ SMActual DumpPackage -> Map PackageName DumpPackage
forall global. SMActual global -> Map PackageName global
smaGlobal SMActual DumpPackage
smActual
                  }
      Utf8Builder -> RIO BuildConfig ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"DotConfig fully loaded"
      DotConfig -> RIO DotConfig a -> RIO BuildConfig a
forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO DotConfig
dc RIO DotConfig a
inner

    withReal :: RIO Config a
withReal = NeedTargets -> BuildOptsCLI -> RIO EnvConfig a -> RIO Config a
forall a.
NeedTargets -> BuildOptsCLI -> RIO EnvConfig a -> RIO Config a
withEnvConfig NeedTargets
NeedTargets BuildOptsCLI
boptsCLI (RIO EnvConfig a -> RIO Config a)
-> RIO EnvConfig a -> RIO Config a
forall a b. (a -> b) -> a -> b
$ do
      EnvConfig
envConfig <- RIO EnvConfig EnvConfig
forall r (m :: * -> *). MonadReader r m => m r
ask
      let sourceMap :: SourceMap
sourceMap = EnvConfig -> SourceMap
envConfigSourceMap EnvConfig
envConfig
      InstallMap
installMap <- SourceMap -> RIO EnvConfig InstallMap
forall (m :: * -> *). MonadIO m => SourceMap -> m InstallMap
toInstallMap SourceMap
sourceMap
      (InstalledMap
_, [DumpPackage]
globalDump, [DumpPackage]
_, [DumpPackage]
_) <- InstallMap
-> RIO
     EnvConfig
     (InstalledMap, [DumpPackage], [DumpPackage], [DumpPackage])
forall env.
HasEnvConfig env =>
InstallMap
-> RIO
     env (InstalledMap, [DumpPackage], [DumpPackage], [DumpPackage])
getInstalled InstallMap
installMap
      let dc :: DotConfig
dc = DotConfig :: BuildConfig -> SourceMap -> [DumpPackage] -> DotConfig
DotConfig
            { dcBuildConfig :: BuildConfig
dcBuildConfig = EnvConfig -> BuildConfig
envConfigBuildConfig EnvConfig
envConfig
            , dcSourceMap :: SourceMap
dcSourceMap = SourceMap
sourceMap
            , dcGlobalDump :: [DumpPackage]
dcGlobalDump = [DumpPackage]
globalDump
            }
      DotConfig -> RIO DotConfig a -> RIO EnvConfig a
forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO DotConfig
dc RIO DotConfig a
inner

    boptsCLI :: BuildOptsCLI
boptsCLI = BuildOptsCLI
defaultBuildOptsCLI
        { boptsCLITargets :: [Text]
boptsCLITargets = DotOpts -> [Text]
dotTargets DotOpts
opts
        , boptsCLIFlags :: Map ApplyCLIFlag (Map FlagName Bool)
boptsCLIFlags = DotOpts -> Map ApplyCLIFlag (Map FlagName Bool)
dotFlags DotOpts
opts
        }
    modifyGO :: GlobalOpts -> GlobalOpts
modifyGO =
        (if DotOpts -> Bool
dotTestTargets DotOpts
opts then ASetter GlobalOpts GlobalOpts (Maybe Bool) (Maybe Bool)
-> Maybe Bool -> GlobalOpts -> GlobalOpts
forall s t a b. ASetter s t a b -> b -> s -> t
set ((BuildOptsMonoid -> Identity BuildOptsMonoid)
-> GlobalOpts -> Identity GlobalOpts
Lens' GlobalOpts BuildOptsMonoid
globalOptsBuildOptsMonoidL((BuildOptsMonoid -> Identity BuildOptsMonoid)
 -> GlobalOpts -> Identity GlobalOpts)
-> ((Maybe Bool -> Identity (Maybe Bool))
    -> BuildOptsMonoid -> Identity BuildOptsMonoid)
-> ASetter GlobalOpts GlobalOpts (Maybe Bool) (Maybe Bool)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Maybe Bool -> Identity (Maybe Bool))
-> BuildOptsMonoid -> Identity BuildOptsMonoid
Lens' BuildOptsMonoid (Maybe Bool)
buildOptsMonoidTestsL) (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True) else GlobalOpts -> GlobalOpts
forall a. a -> a
id) (GlobalOpts -> GlobalOpts)
-> (GlobalOpts -> GlobalOpts) -> GlobalOpts -> GlobalOpts
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        (if DotOpts -> Bool
dotBenchTargets DotOpts
opts then ASetter GlobalOpts GlobalOpts (Maybe Bool) (Maybe Bool)
-> Maybe Bool -> GlobalOpts -> GlobalOpts
forall s t a b. ASetter s t a b -> b -> s -> t
set ((BuildOptsMonoid -> Identity BuildOptsMonoid)
-> GlobalOpts -> Identity GlobalOpts
Lens' GlobalOpts BuildOptsMonoid
globalOptsBuildOptsMonoidL((BuildOptsMonoid -> Identity BuildOptsMonoid)
 -> GlobalOpts -> Identity GlobalOpts)
-> ((Maybe Bool -> Identity (Maybe Bool))
    -> BuildOptsMonoid -> Identity BuildOptsMonoid)
-> ASetter GlobalOpts GlobalOpts (Maybe Bool) (Maybe Bool)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Maybe Bool -> Identity (Maybe Bool))
-> BuildOptsMonoid -> Identity BuildOptsMonoid
Lens' BuildOptsMonoid (Maybe Bool)
buildOptsMonoidBenchmarksL) (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True) else GlobalOpts -> GlobalOpts
forall a. a -> a
id)

data DotConfig = DotConfig
  { DotConfig -> BuildConfig
dcBuildConfig :: !BuildConfig
  , DotConfig -> SourceMap
dcSourceMap :: !SourceMap
  , DotConfig -> [DumpPackage]
dcGlobalDump :: ![DumpPackage]
  }
instance HasLogFunc DotConfig where
  logFuncL :: (LogFunc -> f LogFunc) -> DotConfig -> f DotConfig
logFuncL = (Runner -> f Runner) -> DotConfig -> f DotConfig
forall env. HasRunner env => Lens' env Runner
runnerL((Runner -> f Runner) -> DotConfig -> f DotConfig)
-> ((LogFunc -> f LogFunc) -> Runner -> f Runner)
-> (LogFunc -> f LogFunc)
-> DotConfig
-> f DotConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(LogFunc -> f LogFunc) -> Runner -> f Runner
forall env. HasLogFunc env => Lens' env LogFunc
logFuncL
instance HasPantryConfig DotConfig where
  pantryConfigL :: (PantryConfig -> f PantryConfig) -> DotConfig -> f DotConfig
pantryConfigL = (Config -> f Config) -> DotConfig -> f DotConfig
forall env. HasConfig env => Lens' env Config
configL((Config -> f Config) -> DotConfig -> f DotConfig)
-> ((PantryConfig -> f PantryConfig) -> Config -> f Config)
-> (PantryConfig -> f PantryConfig)
-> DotConfig
-> f DotConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(PantryConfig -> f PantryConfig) -> Config -> f Config
forall env. HasPantryConfig env => Lens' env PantryConfig
pantryConfigL
instance HasTerm DotConfig where
  useColorL :: (Bool -> f Bool) -> DotConfig -> f DotConfig
useColorL = (Runner -> f Runner) -> DotConfig -> f DotConfig
forall env. HasRunner env => Lens' env Runner
runnerL((Runner -> f Runner) -> DotConfig -> f DotConfig)
-> ((Bool -> f Bool) -> Runner -> f Runner)
-> (Bool -> f Bool)
-> DotConfig
-> f DotConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Bool -> f Bool) -> Runner -> f Runner
forall env. HasTerm env => Lens' env Bool
useColorL
  termWidthL :: (Int -> f Int) -> DotConfig -> f DotConfig
termWidthL = (Runner -> f Runner) -> DotConfig -> f DotConfig
forall env. HasRunner env => Lens' env Runner
runnerL((Runner -> f Runner) -> DotConfig -> f DotConfig)
-> ((Int -> f Int) -> Runner -> f Runner)
-> (Int -> f Int)
-> DotConfig
-> f DotConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Int -> f Int) -> Runner -> f Runner
forall env. HasTerm env => Lens' env Int
termWidthL
instance HasStylesUpdate DotConfig where
  stylesUpdateL :: (StylesUpdate -> f StylesUpdate) -> DotConfig -> f DotConfig
stylesUpdateL = (Runner -> f Runner) -> DotConfig -> f DotConfig
forall env. HasRunner env => Lens' env Runner
runnerL((Runner -> f Runner) -> DotConfig -> f DotConfig)
-> ((StylesUpdate -> f StylesUpdate) -> Runner -> f Runner)
-> (StylesUpdate -> f StylesUpdate)
-> DotConfig
-> f DotConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(StylesUpdate -> f StylesUpdate) -> Runner -> f Runner
forall env. HasStylesUpdate env => Lens' env StylesUpdate
stylesUpdateL
instance HasGHCVariant DotConfig
instance HasPlatform DotConfig
instance HasRunner DotConfig where
  runnerL :: (Runner -> f Runner) -> DotConfig -> f DotConfig
runnerL = (Config -> f Config) -> DotConfig -> f DotConfig
forall env. HasConfig env => Lens' env Config
configL((Config -> f Config) -> DotConfig -> f DotConfig)
-> ((Runner -> f Runner) -> Config -> f Config)
-> (Runner -> f Runner)
-> DotConfig
-> f DotConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Runner -> f Runner) -> Config -> f Config
forall env. HasRunner env => Lens' env Runner
runnerL
instance HasProcessContext DotConfig where
  processContextL :: (ProcessContext -> f ProcessContext) -> DotConfig -> f DotConfig
processContextL = (Runner -> f Runner) -> DotConfig -> f DotConfig
forall env. HasRunner env => Lens' env Runner
runnerL((Runner -> f Runner) -> DotConfig -> f DotConfig)
-> ((ProcessContext -> f ProcessContext) -> Runner -> f Runner)
-> (ProcessContext -> f ProcessContext)
-> DotConfig
-> f DotConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(ProcessContext -> f ProcessContext) -> Runner -> f Runner
forall env. HasProcessContext env => Lens' env ProcessContext
processContextL
instance HasConfig DotConfig
instance HasBuildConfig DotConfig where
  buildConfigL :: (BuildConfig -> f BuildConfig) -> DotConfig -> f DotConfig
buildConfigL = (DotConfig -> BuildConfig)
-> (DotConfig -> BuildConfig -> DotConfig)
-> Lens' DotConfig BuildConfig
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens DotConfig -> BuildConfig
dcBuildConfig (\DotConfig
x BuildConfig
y -> DotConfig
x { dcBuildConfig :: BuildConfig
dcBuildConfig = BuildConfig
y })
instance HasSourceMap DotConfig where
  sourceMapL :: (SourceMap -> f SourceMap) -> DotConfig -> f DotConfig
sourceMapL = (DotConfig -> SourceMap)
-> (DotConfig -> SourceMap -> DotConfig)
-> Lens' DotConfig SourceMap
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens DotConfig -> SourceMap
dcSourceMap (\DotConfig
x SourceMap
y -> DotConfig
x { dcSourceMap :: SourceMap
dcSourceMap = SourceMap
y })