{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}

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

import           Data.Aeson ( ToJSON (..), Value, (.=), encode, object )
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.License ( License (BSD3), licenseFromSPDX )
import qualified Distribution.PackageDescription as PD
import qualified Distribution.SPDX.License as SPDX
import           Distribution.Text ( display )
import           Distribution.Types.PackageName ( mkPackageName )
import           Path ( parent )
import           RIO.Process ( HasProcessContext (..) )
import           Stack.Build ( loadPackage )
import           Stack.Build.Installed ( getInstalled, toInstallMap )
import           Stack.Build.Source
                   ( loadCommonPackage, loadLocalPackage, loadSourceMap )
import           Stack.Build.Target( NeedTargets (..), parseTargets )
import           Stack.Constants ( wiredInPackages )
import           Stack.Package ( Package (..) )
import           Stack.Prelude hiding ( Display (..), pkgName, loadPackage )
import qualified Stack.Prelude ( pkgName )
import           Stack.Runners
                   ( ShouldReexec (..), withBuildConfig, withConfig
                   , withEnvConfig
                   )
import           Stack.SourceMap
                   ( globalsFromHints, mkProjectPackage, pruneGlobals )
import           Stack.Types.BuildConfig
                   ( BuildConfig (..), HasBuildConfig (..) )
import           Stack.Types.BuildOpts
                   ( ApplyCLIFlag, BuildOptsCLI (..), buildOptsMonoidBenchmarksL
                   , buildOptsMonoidTestsL, defaultBuildOptsCLI
                   )
import           Stack.Types.Compiler ( wantedToActual )
import           Stack.Types.Config ( HasConfig (..) )
import           Stack.Types.DumpPackage ( DumpPackage (..) )
import           Stack.Types.EnvConfig ( EnvConfig (..), HasSourceMap (..) )
import           Stack.Types.GHCVariant ( HasGHCVariant (..) )
import           Stack.Types.GhcPkgId
                   ( GhcPkgId, ghcPkgIdString, parseGhcPkgId )
import           Stack.Types.GlobalOpts ( globalOptsBuildOptsMonoidL )
import           Stack.Types.Package ( LocalPackage (..) )
import           Stack.Types.Platform ( HasPlatform (..) )
import           Stack.Types.Runner ( HasRunner (..), Runner, globalOptsL )
import           Stack.Types.SourceMap
                   ( CommonPackage (..), DepPackage (..), ProjectPackage (..)
                   , SMActual (..), SMWanted (..), SourceMap (..)
                   )

-- | Type representing exceptions thrown by functions exported by the

-- "Stack.Dot" module.

data DotException
  = DependencyNotFoundBug GhcPkgId
  | PackageNotFoundBug PackageName
  deriving (Int -> DotException -> ShowS
[DotException] -> ShowS
DotException -> [Char]
(Int -> DotException -> ShowS)
-> (DotException -> [Char])
-> ([DotException] -> ShowS)
-> Show DotException
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DotException -> ShowS
showsPrec :: Int -> DotException -> ShowS
$cshow :: DotException -> [Char]
show :: DotException -> [Char]
$cshowList :: [DotException] -> ShowS
showList :: [DotException] -> ShowS
Show, Typeable)

instance Exception DotException where
  displayException :: DotException -> [Char]
displayException (DependencyNotFoundBug GhcPkgId
depId) = [Char] -> ShowS
bugReport [Char]
"[S-7071]" ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [Char]
"Expected to find "
    , GhcPkgId -> [Char]
ghcPkgIdString GhcPkgId
depId
    , [Char]
" in global DB."
    ]
  displayException (PackageNotFoundBug PackageName
pkgName) = [Char] -> ShowS
bugReport [Char]
"[S-7151]" ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [Char]
"The '"
    , PackageName -> [Char]
packageNameString PackageName
pkgName
    , [Char]
"' package was not found in any of the dependency sources."
    ]

-- | 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
  | ListDepsConstraints

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
$c== :: DotPayload -> DotPayload -> Bool
== :: DotPayload -> DotPayload -> Bool
$c/= :: DotPayload -> DotPayload -> Bool
/= :: DotPayload -> DotPayload -> Bool
Eq, Int -> DotPayload -> ShowS
[DotPayload] -> ShowS
DotPayload -> [Char]
(Int -> DotPayload -> ShowS)
-> (DotPayload -> [Char])
-> ([DotPayload] -> ShowS)
-> Show DotPayload
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DotPayload -> ShowS
showsPrec :: Int -> DotPayload -> ShowS
$cshow :: DotPayload -> [Char]
show :: DotPayload -> [Char]
$cshowList :: [DotPayload] -> ShowS
showList :: [DotPayload] -> ShowS
Show)

-- | Create the dependency graph and also prune it as specified in the dot

-- options. Returns a set of local names 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
Lens' DotConfig 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 pruned dependency graph"
  (Set PackageName, Map PackageName (Set PackageName, DotPayload))
-> RIO
     DotConfig
     (Set PackageName, Map PackageName (Set PackageName, DotPayload))
forall a. a -> RIO DotConfig a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (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
Lens' DotConfig 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 a. Map PackageName a -> [a]
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 -> GhcPkgId
dpGhcPkgId (DumpPackage -> GhcPkgId)
-> (DumpPackage -> PackageIdentifier)
-> DumpPackage
-> (GhcPkgId, PackageIdentifier)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& DumpPackage -> PackageIdentifier
dpPackageIdent) [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 a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char] -> PackageName
mkPackageName [Char]
"rts", [Char] -> PackageName
mkPackageName [Char]
"ghc"] =
            (Set PackageName, DotPayload)
-> RIO env (Set PackageName, DotPayload)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ( 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 a b. (a -> b) -> RIO env a -> RIO env b
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 b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
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 a. IO a -> RIO Runner a
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 a b. IO a -> IO b -> IO b
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 (IO (Map PackageName ()) -> IO ())
-> IO (Map PackageName ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ (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 (Text -> ListDepsFormatOpts -> PackageName -> DotPayload -> IO ()
go Text
"" ListDepsFormatOpts
textOpts) ((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)
    ListDepsFormat
ListDepsConstraints -> do
      let constraintOpts :: ListDepsFormatOpts
constraintOpts = Text -> Bool -> ListDepsFormatOpts
ListDepsFormatOpts Text
" ==" Bool
False
      Text -> IO ()
Text.putStrLn Text
"constraints:"
      IO (Map PackageName ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Map PackageName ()) -> IO ())
-> IO (Map PackageName ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ (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 (Text -> ListDepsFormatOpts -> PackageName -> DotPayload -> IO ()
go Text
"  , " ListDepsFormatOpts
constraintOpts)
                                 ((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 :: Text -> ListDepsFormatOpts -> PackageName -> DotPayload -> IO ()
go Text
prefix ListDepsFormatOpts
lineOpts PackageName
name DotPayload
payload =
    Text -> IO ()
Text.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ListDepsFormatOpts -> PackageName -> DotPayload -> Text
listDepsLine ListDepsFormatOpts
lineOpts 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 :: forall k a b. (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 = [ Key
"name" Key -> [Char] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= PackageName -> [Char]
packageNameString PackageName
pkg
                            , Key
"license" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= DotPayload -> Text
licenseText DotPayload
payload
                            , Key
"version" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= DotPayload -> Text
versionText DotPayload
payload
                            , Key
"dependencies" Key -> Set [Char] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= (PackageName -> [Char]) -> Set PackageName -> Set [Char]
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map PackageName -> [Char]
packageNameString Set PackageName
deps
                            ]
      loc :: [Pair]
loc = [Maybe Pair] -> [Pair]
forall a. [Maybe a] -> [a]
catMaybes
              [(Key
"location" .=) (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
  [ Key
"type" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= (Text
"project package" :: Text)
  , Key
"url" Key -> [Char] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= ([Char]
"file://" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Path Abs Dir -> [Char]
forall b t. Path b t -> [Char]
toFilePath Path Abs Dir
dir)
  ]
pkgLocToJSON (PLImmutable (PLIHackage PackageIdentifier
pkgid BlobKey
_ TreeKey
_)) = [Pair] -> Value
object
  [ Key
"type" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= (Text
"hackage" :: Text)
  , Key
"url" Key -> [Char] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= ([Char]
"https://hackage.haskell.org/package/" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ PackageIdentifier -> [Char]
forall a. Pretty a => a -> [Char]
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) ->
                [Char] -> Text
Text.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ [Char]
"file://" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Path Abs File -> [Char]
forall b t. Path b t -> [Char]
toFilePath Path Abs File
path
  in  [Pair] -> Value
object
        [ Key
"type" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= (Text
"archive" :: Text)
        , Key
"url" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Text
url
        , Key
"sha256" Key -> SHA256 -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Archive -> SHA256
archiveHash Archive
archive
        , Key
"size" Key -> FileSize -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Archive -> FileSize
archiveSize Archive
archive
        ]
pkgLocToJSON (PLImmutable (PLIRepo Repo
repo PackageMetadata
_)) = [Pair] -> Value
object
  [ Key
"type" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= case Repo -> RepoType
repoType Repo
repo of
                RepoType
RepoGit -> Text
"git" :: Text
                RepoType
RepoHg -> Text
"hg" :: Text
  , Key
"url" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Repo -> Text
repoUrl Repo
repo
  , Key
"commit" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Repo -> Text
repoCommit Repo
repo
  , Key
"subdir" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= 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 a. [a] -> 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 ([Char] -> PackageName
mkPackageName ([Char] -> PackageName) -> (Text -> [Char]) -> Text -> PackageName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
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 a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
              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 pure an error?

          Maybe (Set PackageName, DotPayload)
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

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 a. Set a -> 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 =
  [Char] -> Text
Text.pack (PackageName -> [Char]
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>" ([Char] -> Text
Text.pack ([Char] -> Text)
-> (Either License License -> [Char])
-> Either License License
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. License -> [Char]
forall a. Pretty a => a -> [Char]
display (License -> [Char])
-> (Either License License -> License)
-> Either License License
-> [Char]
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>" ([Char] -> Text
Text.pack ([Char] -> Text) -> (Version -> [Char]) -> Version -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> [Char]
forall a. Pretty a => a -> [Char]
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 :: 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 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 a. Eq a => a -> g a -> 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 -> 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 :: 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)
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 :: forall a. Eq a => (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 a. Eq a => a -> f a -> 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 m. Monoid m => Map PackageName m -> m
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 :: 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 (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 a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure 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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [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 a. Set a -> [a]
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 =
  RIO DotConfig (Set PackageName, DotPayload)
-> Maybe (RIO DotConfig (Set PackageName, DotPayload))
-> RIO DotConfig (Set PackageName, DotPayload)
forall a. a -> Maybe a -> a
fromMaybe (DotException -> RIO DotConfig (Set PackageName, DotPayload)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (DotException -> RIO DotConfig (Set PackageName, DotPayload))
-> DotException -> RIO DotConfig (Set PackageName, DotPayload)
forall a b. (a -> b) -> a -> b
$ PackageName -> DotException
PackageNotFoundBug PackageName
pkgName)
    (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 a. Maybe a -> Maybe a -> Maybe a
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 a. Maybe a -> Maybe a -> Maybe a
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 a. a -> RIO env a
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 a. a -> RIO DotConfig a
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 a. IO a -> RIO DotConfig a
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 a. a -> RIO DotConfig a
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 =
        PackageName
-> (PackageIdentifier -> PackageName)
-> Maybe PackageIdentifier
-> PackageName
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (DotException -> PackageName
forall e a. Exception e => e -> a
impureThrow (DotException -> PackageName) -> DotException -> PackageName
forall a b. (a -> b) -> a -> b
$ GhcPkgId -> DotException
DependencyNotFoundBug GhcPkgId
depId)
              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)

  payloadFromLocal :: Package -> Maybe PackageLocation -> DotPayload
payloadFromLocal 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)

  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
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 :: forall (m :: * -> *).
(Applicative m, MonadIO m) =>
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 a. IO a -> m a
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 a. IO a -> m a
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 :: forall (t :: * -> *) (m :: * -> *).
(Foldable t, MonadIO m) =>
DotOpts -> t PackageName -> m ()
printLocalNodes DotOpts
dotOpts t PackageName
locals =
  IO () -> m ()
forall a. IO a -> m a
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 a. t a -> [a]
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 :: forall (m :: * -> *).
MonadIO m =>
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 a b. (a -> b) -> Map PackageName a -> Map PackageName b
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 :: forall (m :: * -> *).
MonadIO m =>
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 :: forall (m :: * -> *).
MonadIO m =>
PackageName -> PackageName -> m ()
printEdge PackageName
from PackageName
to' =
  IO () -> m ()
forall a. IO a -> m a
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
<> [Char] -> Text
Text.pack (PackageName -> [Char]
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 :: forall (m :: * -> *). MonadIO m => PackageName -> m ()
printLeaf PackageName
package = IO () -> m ()
forall a. IO a -> m a
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 :: forall a. DotOpts -> RIO DotConfig a -> RIO Runner a
withDotConfig DotOpts
opts RIO DotConfig a
inner =
  (Runner -> Runner) -> RIO Runner a -> RIO Runner a
forall a. (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
Lens' Runner 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
Lens' BuildConfig 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 a. a -> RIO BuildConfig a
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
          { 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
          { 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 :: [[Char]]
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 :: [[Char]]
dpHaddockInterfaces = []
          , dpHaddockHtml :: Maybe [Char]
dpHaddockHtml = Maybe [Char]
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
                { dcBuildConfig :: BuildConfig
dcBuildConfig = BuildConfig
bconfig
                , dcSourceMap :: SourceMap
dcSourceMap = SourceMap
sourceMap
                , dcGlobalDump :: [DumpPackage]
dcGlobalDump = Map PackageName DumpPackage -> [DumpPackage]
forall a. Map PackageName a -> [a]
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
          { 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 :: Lens' DotConfig LogFunc
logFuncL = (Runner -> f Runner) -> DotConfig -> f DotConfig
forall env. HasRunner env => Lens' env Runner
Lens' DotConfig 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
Lens' Runner LogFunc
logFuncL

instance HasPantryConfig DotConfig where
  pantryConfigL :: Lens' DotConfig PantryConfig
pantryConfigL = (Config -> f Config) -> DotConfig -> f DotConfig
forall env. HasConfig env => Lens' env Config
Lens' DotConfig 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
Lens' Config PantryConfig
pantryConfigL

instance HasTerm DotConfig where
  useColorL :: Lens' DotConfig Bool
useColorL = (Runner -> f Runner) -> DotConfig -> f DotConfig
forall env. HasRunner env => Lens' env Runner
Lens' DotConfig 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
Lens' Runner Bool
useColorL
  termWidthL :: Lens' DotConfig Int
termWidthL = (Runner -> f Runner) -> DotConfig -> f DotConfig
forall env. HasRunner env => Lens' env Runner
Lens' DotConfig 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
Lens' Runner Int
termWidthL

instance HasStylesUpdate DotConfig where
  stylesUpdateL :: Lens' DotConfig StylesUpdate
stylesUpdateL = (Runner -> f Runner) -> DotConfig -> f DotConfig
forall env. HasRunner env => Lens' env Runner
Lens' DotConfig 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
Lens' Runner StylesUpdate
stylesUpdateL

instance HasGHCVariant DotConfig where
  ghcVariantL :: SimpleGetter DotConfig GHCVariant
ghcVariantL = (Config -> Const r Config) -> DotConfig -> Const r DotConfig
forall env. HasConfig env => Lens' env Config
Lens' DotConfig Config
configL((Config -> Const r Config) -> DotConfig -> Const r DotConfig)
-> ((GHCVariant -> Const r GHCVariant) -> Config -> Const r Config)
-> (GHCVariant -> Const r GHCVariant)
-> DotConfig
-> Const r DotConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(GHCVariant -> Const r GHCVariant) -> Config -> Const r Config
forall env. HasGHCVariant env => SimpleGetter env GHCVariant
SimpleGetter Config GHCVariant
ghcVariantL
  {-# INLINE ghcVariantL #-}

instance HasPlatform DotConfig where
  platformL :: Lens' DotConfig Platform
platformL = (Config -> f Config) -> DotConfig -> f DotConfig
forall env. HasConfig env => Lens' env Config
Lens' DotConfig Config
configL((Config -> f Config) -> DotConfig -> f DotConfig)
-> ((Platform -> f Platform) -> Config -> f Config)
-> (Platform -> f Platform)
-> DotConfig
-> f DotConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Platform -> f Platform) -> Config -> f Config
forall env. HasPlatform env => Lens' env Platform
Lens' Config Platform
platformL
  {-# INLINE platformL #-}
  platformVariantL :: Lens' DotConfig PlatformVariant
platformVariantL = (Config -> f Config) -> DotConfig -> f DotConfig
forall env. HasConfig env => Lens' env Config
Lens' DotConfig Config
configL((Config -> f Config) -> DotConfig -> f DotConfig)
-> ((PlatformVariant -> f PlatformVariant) -> Config -> f Config)
-> (PlatformVariant -> f PlatformVariant)
-> DotConfig
-> f DotConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(PlatformVariant -> f PlatformVariant) -> Config -> f Config
forall env. HasPlatform env => Lens' env PlatformVariant
Lens' Config PlatformVariant
platformVariantL
  {-# INLINE platformVariantL #-}

instance HasRunner DotConfig where
  runnerL :: Lens' DotConfig Runner
runnerL = (Config -> f Config) -> DotConfig -> f DotConfig
forall env. HasConfig env => Lens' env Config
Lens' DotConfig 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
Lens' Config Runner
runnerL

instance HasProcessContext DotConfig where
  processContextL :: Lens' DotConfig ProcessContext
processContextL = (Runner -> f Runner) -> DotConfig -> f DotConfig
forall env. HasRunner env => Lens' env Runner
Lens' DotConfig 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
Lens' Runner ProcessContext
processContextL

instance HasConfig DotConfig where
  configL :: Lens' DotConfig Config
configL = (BuildConfig -> f BuildConfig) -> DotConfig -> f DotConfig
forall env. HasBuildConfig env => Lens' env BuildConfig
Lens' DotConfig BuildConfig
buildConfigL((BuildConfig -> f BuildConfig) -> DotConfig -> f DotConfig)
-> ((Config -> f Config) -> BuildConfig -> f BuildConfig)
-> (Config -> f Config)
-> DotConfig
-> f DotConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(BuildConfig -> Config)
-> (BuildConfig -> Config -> BuildConfig)
-> Lens BuildConfig BuildConfig Config Config
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens BuildConfig -> Config
bcConfig (\BuildConfig
x Config
y -> BuildConfig
x { bcConfig :: Config
bcConfig = Config
y })
  {-# INLINE configL #-}

instance HasBuildConfig DotConfig where
  buildConfigL :: Lens' DotConfig BuildConfig
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 :: Lens' DotConfig SourceMap
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 })