{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
module Stack.Dot (dot
,listDependencies
,DotOpts(..)
,DotPayload(..)
,ListDepsOpts(..)
,ListDepsFormat(..)
,ListDepsFormatOpts(..)
,resolveDependencies
,printGraph
,pruneGraph
) where
import Data.Aeson
import qualified Data.ByteString.Lazy.Char8 as LBC8
import qualified Data.Foldable as F
import qualified Data.Sequence as Seq
import qualified Data.Set as Set
import qualified Data.Map as Map
import qualified Data.Text as Text
import qualified Data.Text.IO as Text
import qualified Data.Traversable as T
import Distribution.Text (display)
import qualified Distribution.PackageDescription as PD
import qualified Distribution.SPDX.License as SPDX
import Distribution.License (License(BSD3), licenseFromSPDX)
import Distribution.Types.PackageName (mkPackageName)
import qualified Path
import RIO.PrettyPrint (HasTerm (..), HasStylesUpdate (..))
import RIO.Process (HasProcessContext (..))
import Stack.Build (loadPackage)
import Stack.Build.Installed (getInstalled, toInstallMap)
import Stack.Build.Source
import Stack.Constants
import Stack.Package
import Stack.Prelude hiding (Display (..), pkgName, loadPackage)
import qualified Stack.Prelude (pkgName)
import Stack.Runners
import Stack.SourceMap
import Stack.Types.Build
import Stack.Types.Compiler (wantedToActual)
import Stack.Types.Config
import Stack.Types.GhcPkgId
import Stack.Types.SourceMap
import Stack.Build.Target(NeedTargets(..), parseTargets)
data DotOpts = DotOpts
{ DotOpts -> Bool
dotIncludeExternal :: !Bool
, DotOpts -> Bool
dotIncludeBase :: !Bool
, DotOpts -> Maybe Int
dotDependencyDepth :: !(Maybe Int)
, DotOpts -> Set PackageName
dotPrune :: !(Set PackageName)
, DotOpts -> [Text]
dotTargets :: [Text]
, DotOpts -> Map ApplyCLIFlag (Map FlagName Bool)
dotFlags :: !(Map ApplyCLIFlag (Map FlagName Bool))
, DotOpts -> Bool
dotTestTargets :: Bool
, DotOpts -> Bool
dotBenchTargets :: Bool
, DotOpts -> Bool
dotGlobalHints :: Bool
}
data ListDepsFormatOpts = ListDepsFormatOpts { ListDepsFormatOpts -> Text
listDepsSep :: !Text
, ListDepsFormatOpts -> Bool
listDepsLicense :: !Bool
}
data ListDepsFormat = ListDepsText ListDepsFormatOpts
| ListDepsTree ListDepsFormatOpts
| ListDepsJSON
data ListDepsOpts = ListDepsOpts
{ ListDepsOpts -> ListDepsFormat
listDepsFormat :: !ListDepsFormat
, ListDepsOpts -> DotOpts
listDepsDotOpts :: !DotOpts
}
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
data DotPayload = DotPayload
{ DotPayload -> Maybe Version
payloadVersion :: Maybe Version
, DotPayload -> Maybe (Either License License)
payloadLicense :: Maybe (Either SPDX.License License)
, DotPayload -> Maybe PackageLocation
payloadLocation :: Maybe PackageLocation
} deriving (DotPayload -> DotPayload -> Bool
(DotPayload -> DotPayload -> Bool)
-> (DotPayload -> DotPayload -> Bool) -> Eq DotPayload
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DotPayload -> DotPayload -> Bool
$c/= :: DotPayload -> DotPayload -> Bool
== :: DotPayload -> DotPayload -> Bool
$c== :: DotPayload -> DotPayload -> Bool
Eq, Int -> DotPayload -> ShowS
[DotPayload] -> ShowS
DotPayload -> String
(Int -> DotPayload -> ShowS)
-> (DotPayload -> String)
-> ([DotPayload] -> ShowS)
-> Show DotPayload
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DotPayload] -> ShowS
$cshowList :: [DotPayload] -> ShowS
show :: DotPayload -> String
$cshow :: DotPayload -> String
showsPrec :: Int -> DotPayload -> ShowS
$cshowsPrec :: Int -> DotPayload -> ShowS
Show)
createPrunedDependencyGraph :: DotOpts
-> RIO Runner
(Set PackageName,
Map PackageName (Set PackageName, DotPayload))
createPrunedDependencyGraph :: DotOpts
-> RIO
Runner
(Set PackageName, Map PackageName (Set PackageName, DotPayload))
createPrunedDependencyGraph DotOpts
dotOpts = DotOpts
-> RIO
DotConfig
(Set PackageName, Map PackageName (Set PackageName, DotPayload))
-> RIO
Runner
(Set PackageName, Map PackageName (Set PackageName, DotPayload))
forall a. DotOpts -> RIO DotConfig a -> RIO Runner a
withDotConfig DotOpts
dotOpts (RIO
DotConfig
(Set PackageName, Map PackageName (Set PackageName, DotPayload))
-> RIO
Runner
(Set PackageName, Map PackageName (Set PackageName, DotPayload)))
-> RIO
DotConfig
(Set PackageName, Map PackageName (Set PackageName, DotPayload))
-> RIO
Runner
(Set PackageName, Map PackageName (Set PackageName, DotPayload))
forall a b. (a -> b) -> a -> b
$ do
Set PackageName
localNames <- Getting (Set PackageName) DotConfig (Set PackageName)
-> RIO DotConfig (Set PackageName)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting (Set PackageName) DotConfig (Set PackageName)
-> RIO DotConfig (Set PackageName))
-> Getting (Set PackageName) DotConfig (Set PackageName)
-> RIO DotConfig (Set PackageName)
forall a b. (a -> b) -> a -> b
$ (BuildConfig -> Const (Set PackageName) BuildConfig)
-> DotConfig -> Const (Set PackageName) DotConfig
forall env. HasBuildConfig env => Lens' env BuildConfig
buildConfigL((BuildConfig -> Const (Set PackageName) BuildConfig)
-> DotConfig -> Const (Set PackageName) DotConfig)
-> ((Set PackageName -> Const (Set PackageName) (Set PackageName))
-> BuildConfig -> Const (Set PackageName) BuildConfig)
-> Getting (Set PackageName) DotConfig (Set PackageName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(BuildConfig -> Set PackageName)
-> SimpleGetter BuildConfig (Set PackageName)
forall s a. (s -> a) -> SimpleGetter s a
to (Map PackageName ProjectPackage -> Set PackageName
forall k a. Map k a -> Set k
Map.keysSet (Map PackageName ProjectPackage -> Set PackageName)
-> (BuildConfig -> Map PackageName ProjectPackage)
-> BuildConfig
-> Set PackageName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SMWanted -> Map PackageName ProjectPackage
smwProject (SMWanted -> Map PackageName ProjectPackage)
-> (BuildConfig -> SMWanted)
-> BuildConfig
-> Map PackageName ProjectPackage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BuildConfig -> SMWanted
bcSMWanted)
Utf8Builder -> RIO DotConfig ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Creating dependency graph"
Map PackageName (Set PackageName, DotPayload)
resultGraph <- DotOpts
-> RIO DotConfig (Map PackageName (Set PackageName, DotPayload))
createDependencyGraph DotOpts
dotOpts
let pkgsToPrune :: Set PackageName
pkgsToPrune = if DotOpts -> Bool
dotIncludeBase DotOpts
dotOpts
then DotOpts -> Set PackageName
dotPrune DotOpts
dotOpts
else PackageName -> Set PackageName -> Set PackageName
forall a. Ord a => a -> Set a -> Set a
Set.insert PackageName
"base" (DotOpts -> Set PackageName
dotPrune DotOpts
dotOpts)
prunedGraph :: Map PackageName (Set PackageName, DotPayload)
prunedGraph = Set PackageName
-> Set PackageName
-> Map PackageName (Set PackageName, DotPayload)
-> Map PackageName (Set PackageName, DotPayload)
forall (f :: * -> *) (g :: * -> *) a.
(Foldable f, Foldable g, Eq a) =>
f PackageName
-> g PackageName
-> Map PackageName (Set PackageName, a)
-> Map PackageName (Set PackageName, a)
pruneGraph Set PackageName
localNames Set PackageName
pkgsToPrune Map PackageName (Set PackageName, DotPayload)
resultGraph
Utf8Builder -> RIO DotConfig ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Returning prouned dependency graph"
(Set PackageName, Map PackageName (Set PackageName, DotPayload))
-> RIO
DotConfig
(Set PackageName, Map PackageName (Set PackageName, DotPayload))
forall (m :: * -> *) a. Monad m => a -> m a
return (Set PackageName
localNames, Map PackageName (Set PackageName, DotPayload)
prunedGraph)
createDependencyGraph
:: DotOpts
-> RIO DotConfig (Map PackageName (Set PackageName, DotPayload))
createDependencyGraph :: DotOpts
-> RIO DotConfig (Map PackageName (Set PackageName, DotPayload))
createDependencyGraph DotOpts
dotOpts = do
SourceMap
sourceMap <- Getting SourceMap DotConfig SourceMap -> RIO DotConfig SourceMap
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting SourceMap DotConfig SourceMap
forall env. HasSourceMap env => Lens' env SourceMap
sourceMapL
[LocalPackage]
locals <- [ProjectPackage]
-> (ProjectPackage -> RIO DotConfig LocalPackage)
-> RIO DotConfig [LocalPackage]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (Map PackageName ProjectPackage -> [ProjectPackage]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Map PackageName ProjectPackage -> [ProjectPackage])
-> Map PackageName ProjectPackage -> [ProjectPackage]
forall a b. (a -> b) -> a -> b
$ SourceMap -> Map PackageName ProjectPackage
smProject SourceMap
sourceMap) ProjectPackage -> RIO DotConfig LocalPackage
forall env.
(HasBuildConfig env, HasSourceMap env) =>
ProjectPackage -> RIO env LocalPackage
loadLocalPackage
let graph :: Map PackageName (Set PackageName, DotPayload)
graph = [(PackageName, (Set PackageName, DotPayload))]
-> Map PackageName (Set PackageName, DotPayload)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(PackageName, (Set PackageName, DotPayload))]
-> Map PackageName (Set PackageName, DotPayload))
-> [(PackageName, (Set PackageName, DotPayload))]
-> Map PackageName (Set PackageName, DotPayload)
forall a b. (a -> b) -> a -> b
$ DotOpts
-> [LocalPackage] -> [(PackageName, (Set PackageName, DotPayload))]
projectPackageDependencies DotOpts
dotOpts ((LocalPackage -> Bool) -> [LocalPackage] -> [LocalPackage]
forall a. (a -> Bool) -> [a] -> [a]
filter LocalPackage -> Bool
lpWanted [LocalPackage]
locals)
[DumpPackage]
globalDump <- Getting [DumpPackage] DotConfig [DumpPackage]
-> RIO DotConfig [DumpPackage]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting [DumpPackage] DotConfig [DumpPackage]
-> RIO DotConfig [DumpPackage])
-> Getting [DumpPackage] DotConfig [DumpPackage]
-> RIO DotConfig [DumpPackage]
forall a b. (a -> b) -> a -> b
$ (DotConfig -> [DumpPackage])
-> SimpleGetter DotConfig [DumpPackage]
forall s a. (s -> a) -> SimpleGetter s a
to DotConfig -> [DumpPackage]
dcGlobalDump
let globalDumpMap :: Map PackageName DumpPackage
globalDumpMap = [(PackageName, DumpPackage)] -> Map PackageName DumpPackage
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(PackageName, DumpPackage)] -> Map PackageName DumpPackage)
-> [(PackageName, DumpPackage)] -> Map PackageName DumpPackage
forall a b. (a -> b) -> a -> b
$ (DumpPackage -> (PackageName, DumpPackage))
-> [DumpPackage] -> [(PackageName, DumpPackage)]
forall a b. (a -> b) -> [a] -> [b]
map (\DumpPackage
dp -> (PackageIdentifier -> PackageName
Stack.Prelude.pkgName (DumpPackage -> PackageIdentifier
dpPackageIdent DumpPackage
dp), DumpPackage
dp)) [DumpPackage]
globalDump
globalIdMap :: Map GhcPkgId PackageIdentifier
globalIdMap = [(GhcPkgId, PackageIdentifier)] -> Map GhcPkgId PackageIdentifier
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(GhcPkgId, PackageIdentifier)] -> Map GhcPkgId PackageIdentifier)
-> [(GhcPkgId, PackageIdentifier)]
-> Map GhcPkgId PackageIdentifier
forall a b. (a -> b) -> a -> b
$ (DumpPackage -> (GhcPkgId, PackageIdentifier))
-> [DumpPackage] -> [(GhcPkgId, PackageIdentifier)]
forall a b. (a -> b) -> [a] -> [b]
map (\DumpPackage
dp -> (DumpPackage -> GhcPkgId
dpGhcPkgId DumpPackage
dp, DumpPackage -> PackageIdentifier
dpPackageIdent DumpPackage
dp)) [DumpPackage]
globalDump
let depLoader :: PackageName -> RIO DotConfig (Set PackageName, DotPayload)
depLoader = SourceMap
-> Map PackageName DumpPackage
-> Map GhcPkgId PackageIdentifier
-> (PackageName
-> Version
-> PackageLocationImmutable
-> Map FlagName Bool
-> [Text]
-> [Text]
-> RIO DotConfig (Set PackageName, DotPayload))
-> PackageName
-> RIO DotConfig (Set PackageName, DotPayload)
createDepLoader SourceMap
sourceMap Map PackageName DumpPackage
globalDumpMap Map GhcPkgId PackageIdentifier
globalIdMap PackageName
-> Version
-> PackageLocationImmutable
-> Map FlagName Bool
-> [Text]
-> [Text]
-> RIO DotConfig (Set PackageName, DotPayload)
forall env.
(HasBuildConfig env, HasSourceMap env) =>
PackageName
-> Version
-> PackageLocationImmutable
-> Map FlagName Bool
-> [Text]
-> [Text]
-> RIO env (Set PackageName, DotPayload)
loadPackageDeps
loadPackageDeps :: PackageName
-> Version
-> PackageLocationImmutable
-> Map FlagName Bool
-> [Text]
-> [Text]
-> RIO env (Set PackageName, DotPayload)
loadPackageDeps PackageName
name Version
version PackageLocationImmutable
loc Map FlagName Bool
flags [Text]
ghcOptions [Text]
cabalConfigOpts
| PackageName
name PackageName -> [PackageName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String -> PackageName
mkPackageName String
"rts", String -> PackageName
mkPackageName String
"ghc"] =
(Set PackageName, DotPayload)
-> RIO env (Set PackageName, DotPayload)
forall (m :: * -> *) a. Monad m => a -> m a
return (Set PackageName
forall a. Set a
Set.empty, Maybe Version
-> Maybe (Either License License)
-> Maybe PackageLocation
-> DotPayload
DotPayload (Version -> Maybe Version
forall a. a -> Maybe a
Just Version
version) (Either License License -> Maybe (Either License License)
forall a. a -> Maybe a
Just (Either License License -> Maybe (Either License License))
-> Either License License -> Maybe (Either License License)
forall a b. (a -> b) -> a -> b
$ License -> Either License License
forall a b. b -> Either a b
Right License
BSD3) Maybe PackageLocation
forall a. Maybe a
Nothing)
| Bool
otherwise =
(Package -> (Set PackageName, DotPayload))
-> RIO env Package -> RIO env (Set PackageName, DotPayload)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Package -> Set PackageName
packageAllDeps (Package -> Set PackageName)
-> (Package -> DotPayload)
-> Package
-> (Set PackageName, DotPayload)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& PackageLocationImmutable -> Package -> DotPayload
makePayload PackageLocationImmutable
loc) (PackageLocationImmutable
-> Map FlagName Bool -> [Text] -> [Text] -> RIO env Package
forall env.
(HasBuildConfig env, HasSourceMap env) =>
PackageLocationImmutable
-> Map FlagName Bool -> [Text] -> [Text] -> RIO env Package
loadPackage PackageLocationImmutable
loc Map FlagName Bool
flags [Text]
ghcOptions [Text]
cabalConfigOpts)
Maybe Int
-> Map PackageName (Set PackageName, DotPayload)
-> (PackageName -> RIO DotConfig (Set PackageName, DotPayload))
-> RIO DotConfig (Map PackageName (Set PackageName, DotPayload))
forall (m :: * -> *).
(Applicative m, Monad m) =>
Maybe Int
-> Map PackageName (Set PackageName, DotPayload)
-> (PackageName -> m (Set PackageName, DotPayload))
-> m (Map PackageName (Set PackageName, DotPayload))
resolveDependencies (DotOpts -> Maybe Int
dotDependencyDepth DotOpts
dotOpts) Map PackageName (Set PackageName, DotPayload)
graph PackageName -> RIO DotConfig (Set PackageName, DotPayload)
depLoader
where makePayload :: PackageLocationImmutable -> Package -> DotPayload
makePayload PackageLocationImmutable
loc Package
pkg = Maybe Version
-> Maybe (Either License License)
-> Maybe PackageLocation
-> DotPayload
DotPayload (Version -> Maybe Version
forall a. a -> Maybe a
Just (Version -> Maybe Version) -> Version -> Maybe Version
forall a b. (a -> b) -> a -> b
$ Package -> Version
packageVersion Package
pkg) (Either License License -> Maybe (Either License License)
forall a. a -> Maybe a
Just (Either License License -> Maybe (Either License License))
-> Either License License -> Maybe (Either License License)
forall a b. (a -> b) -> a -> b
$ Package -> Either License License
packageLicense Package
pkg) (PackageLocation -> Maybe PackageLocation
forall a. a -> Maybe a
Just (PackageLocation -> Maybe PackageLocation)
-> PackageLocation -> Maybe PackageLocation
forall a b. (a -> b) -> a -> b
$ PackageLocationImmutable -> PackageLocation
PLImmutable PackageLocationImmutable
loc)
listDependencies
:: ListDepsOpts
-> RIO Runner ()
listDependencies :: ListDepsOpts -> RIO Runner ()
listDependencies ListDepsOpts
opts = do
let dotOpts :: DotOpts
dotOpts = ListDepsOpts -> DotOpts
listDepsDotOpts ListDepsOpts
opts
(Set PackageName
pkgs, Map PackageName (Set PackageName, DotPayload)
resultGraph) <- DotOpts
-> RIO
Runner
(Set PackageName, Map PackageName (Set PackageName, DotPayload))
createPrunedDependencyGraph DotOpts
dotOpts
IO () -> RIO Runner ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO Runner ()) -> IO () -> RIO Runner ()
forall a b. (a -> b) -> a -> b
$ case ListDepsOpts -> ListDepsFormat
listDepsFormat ListDepsOpts
opts of
ListDepsTree ListDepsFormatOpts
treeOpts -> Text -> IO ()
Text.putStrLn Text
"Packages" IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ListDepsFormatOpts
-> DotOpts
-> Int
-> [Int]
-> Set PackageName
-> Map PackageName (Set PackageName, DotPayload)
-> IO ()
printTree ListDepsFormatOpts
treeOpts DotOpts
dotOpts Int
0 [] (ListDepsOpts -> Set PackageName -> Set PackageName
treeRoots ListDepsOpts
opts Set PackageName
pkgs) Map PackageName (Set PackageName, DotPayload)
resultGraph
ListDepsFormat
ListDepsJSON -> Set PackageName
-> Map PackageName (Set PackageName, DotPayload) -> IO ()
printJSON Set PackageName
pkgs Map PackageName (Set PackageName, DotPayload)
resultGraph
ListDepsText ListDepsFormatOpts
textOpts -> IO (Map PackageName ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ((PackageName -> DotPayload -> IO ())
-> Map PackageName DotPayload -> IO (Map PackageName ())
forall (t :: * -> *) k a b.
Applicative t =>
(k -> a -> t b) -> Map k a -> t (Map k b)
Map.traverseWithKey PackageName -> DotPayload -> IO ()
go ((Set PackageName, DotPayload) -> DotPayload
forall a b. (a, b) -> b
snd ((Set PackageName, DotPayload) -> DotPayload)
-> Map PackageName (Set PackageName, DotPayload)
-> Map PackageName DotPayload
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map PackageName (Set PackageName, DotPayload)
resultGraph))
where go :: PackageName -> DotPayload -> IO ()
go PackageName
name DotPayload
payload = Text -> IO ()
Text.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ ListDepsFormatOpts -> PackageName -> DotPayload -> Text
listDepsLine ListDepsFormatOpts
textOpts PackageName
name DotPayload
payload
data DependencyTree = DependencyTree (Set PackageName) (Map PackageName (Set PackageName, DotPayload))
instance ToJSON DependencyTree where
toJSON :: DependencyTree -> Value
toJSON (DependencyTree Set PackageName
_ Map PackageName (Set PackageName, DotPayload)
dependencyMap) =
[Value] -> Value
forall a. ToJSON a => a -> Value
toJSON ([Value] -> Value) -> [Value] -> Value
forall a b. (a -> b) -> a -> b
$ (PackageName -> (Set PackageName, DotPayload) -> Value)
-> Map PackageName (Set PackageName, DotPayload) -> [Value]
forall k a b. (k -> a -> b) -> Map k a -> [b]
foldToList PackageName -> (Set PackageName, DotPayload) -> Value
dependencyToJSON Map PackageName (Set PackageName, DotPayload)
dependencyMap
foldToList :: (k -> a -> b) -> Map k a -> [b]
foldToList :: (k -> a -> b) -> Map k a -> [b]
foldToList k -> a -> b
f = (k -> a -> [b] -> [b]) -> [b] -> Map k a -> [b]
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey (\k
k a
a [b]
bs -> [b]
bs [b] -> [b] -> [b]
forall a. [a] -> [a] -> [a]
++ [k -> a -> b
f k
k a
a]) []
dependencyToJSON :: PackageName -> (Set PackageName, DotPayload) -> Value
dependencyToJSON :: PackageName -> (Set PackageName, DotPayload) -> Value
dependencyToJSON PackageName
pkg (Set PackageName
deps, DotPayload
payload) = let fieldsAlwaysPresent :: [Pair]
fieldsAlwaysPresent = [ Text
"name" Text -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= PackageName -> String
packageNameString PackageName
pkg
, Text
"license" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= DotPayload -> Text
licenseText DotPayload
payload
, Text
"version" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= DotPayload -> Text
versionText DotPayload
payload
, Text
"dependencies" Text -> Set String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (PackageName -> String) -> Set PackageName -> Set String
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map PackageName -> String
packageNameString Set PackageName
deps
]
loc :: [Pair]
loc = [Maybe Pair] -> [Pair]
forall a. [Maybe a] -> [a]
catMaybes [(Text
"location" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.=) (Value -> Pair)
-> (PackageLocation -> Value) -> PackageLocation -> Pair
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageLocation -> Value
pkgLocToJSON (PackageLocation -> Pair) -> Maybe PackageLocation -> Maybe Pair
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DotPayload -> Maybe PackageLocation
payloadLocation DotPayload
payload]
in [Pair] -> Value
object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$ [Pair]
fieldsAlwaysPresent [Pair] -> [Pair] -> [Pair]
forall a. [a] -> [a] -> [a]
++ [Pair]
loc
pkgLocToJSON :: PackageLocation -> Value
pkgLocToJSON :: PackageLocation -> Value
pkgLocToJSON (PLMutable (ResolvedPath RelFilePath
_ Path Abs Dir
dir)) = [Pair] -> Value
object [ Text
"type" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (Text
"project package" :: Text)
, Text
"url" Text -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (String
"file://" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Path Abs Dir -> String
forall b t. Path b t -> String
Path.toFilePath Path Abs Dir
dir)]
pkgLocToJSON (PLImmutable (PLIHackage PackageIdentifier
pkgid BlobKey
_ TreeKey
_)) = [Pair] -> Value
object [ Text
"type" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (Text
"hackage" :: Text)
, Text
"url" Text -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (String
"https://hackage.haskell.org/package/" String -> ShowS
forall a. [a] -> [a] -> [a]
++ PackageIdentifier -> String
forall a. Pretty a => a -> String
display PackageIdentifier
pkgid)]
pkgLocToJSON (PLImmutable (PLIArchive Archive
archive PackageMetadata
_)) = let url :: Text
url = case Archive -> ArchiveLocation
archiveLocation Archive
archive of
ALUrl Text
u -> Text
u
ALFilePath (ResolvedPath RelFilePath
_ Path Abs File
path) -> String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"file://" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Path Abs File -> String
forall b t. Path b t -> String
Path.toFilePath Path Abs File
path
in [Pair] -> Value
object [ Text
"type" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (Text
"archive" :: Text)
, Text
"url" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text
url
, Text
"sha256" Text -> SHA256 -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Archive -> SHA256
archiveHash Archive
archive
, Text
"size" Text -> FileSize -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Archive -> FileSize
archiveSize Archive
archive ]
pkgLocToJSON (PLImmutable (PLIRepo Repo
repo PackageMetadata
_)) = [Pair] -> Value
object [ Text
"type" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= case Repo -> RepoType
repoType Repo
repo of
RepoType
RepoGit -> Text
"git" :: Text
RepoType
RepoHg -> Text
"hg" :: Text
, Text
"url" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Repo -> Text
repoUrl Repo
repo
, Text
"commit" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Repo -> Text
repoCommit Repo
repo
, Text
"subdir" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Repo -> Text
repoSubdir Repo
repo
]
printJSON :: Set PackageName
-> Map PackageName (Set PackageName, DotPayload)
-> IO ()
printJSON :: Set PackageName
-> Map PackageName (Set PackageName, DotPayload) -> IO ()
printJSON Set PackageName
pkgs Map PackageName (Set PackageName, DotPayload)
dependencyMap = ByteString -> IO ()
LBC8.putStrLn (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ DependencyTree -> ByteString
forall a. ToJSON a => a -> ByteString
encode (DependencyTree -> ByteString) -> DependencyTree -> ByteString
forall a b. (a -> b) -> a -> b
$ Set PackageName
-> Map PackageName (Set PackageName, DotPayload) -> DependencyTree
DependencyTree Set PackageName
pkgs Map PackageName (Set PackageName, DotPayload)
dependencyMap
treeRoots :: ListDepsOpts -> Set PackageName -> Set PackageName
treeRoots :: ListDepsOpts -> Set PackageName -> Set PackageName
treeRoots ListDepsOpts
opts Set PackageName
projectPackages' =
let targets :: [Text]
targets = DotOpts -> [Text]
dotTargets (DotOpts -> [Text]) -> DotOpts -> [Text]
forall a b. (a -> b) -> a -> b
$ ListDepsOpts -> DotOpts
listDepsDotOpts ListDepsOpts
opts
in if [Text] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
targets
then Set PackageName
projectPackages'
else [PackageName] -> Set PackageName
forall a. Ord a => [a] -> Set a
Set.fromList ([PackageName] -> Set PackageName)
-> [PackageName] -> Set PackageName
forall a b. (a -> b) -> a -> b
$ (Text -> PackageName) -> [Text] -> [PackageName]
forall a b. (a -> b) -> [a] -> [b]
map (String -> PackageName
mkPackageName (String -> PackageName) -> (Text -> String) -> Text -> PackageName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack) [Text]
targets
printTree :: ListDepsFormatOpts
-> DotOpts
-> Int
-> [Int]
-> Set PackageName
-> Map PackageName (Set PackageName, DotPayload)
-> IO ()
printTree :: ListDepsFormatOpts
-> DotOpts
-> Int
-> [Int]
-> Set PackageName
-> Map PackageName (Set PackageName, DotPayload)
-> IO ()
printTree ListDepsFormatOpts
opts DotOpts
dotOpts Int
depth [Int]
remainingDepsCounts Set PackageName
packages Map PackageName (Set PackageName, DotPayload)
dependencyMap =
Seq (IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
F.sequence_ (Seq (IO ()) -> IO ()) -> Seq (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int -> PackageName -> IO ()) -> Seq PackageName -> Seq (IO ())
forall a b. (Int -> a -> b) -> Seq a -> Seq b
Seq.mapWithIndex Int -> PackageName -> IO ()
go (Set PackageName -> Seq PackageName
forall a. Set a -> Seq a
toSeq Set PackageName
packages)
where
toSeq :: Set a -> Seq a
toSeq = [a] -> Seq a
forall a. [a] -> Seq a
Seq.fromList ([a] -> Seq a) -> (Set a -> [a]) -> Set a -> Seq a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set a -> [a]
forall a. Set a -> [a]
Set.toList
go :: Int -> PackageName -> IO ()
go Int
index PackageName
name = let newDepsCounts :: [Int]
newDepsCounts = [Int]
remainingDepsCounts [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Set PackageName -> Int
forall a. Set a -> Int
Set.size Set PackageName
packages Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
index Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
in
case PackageName
-> Map PackageName (Set PackageName, DotPayload)
-> Maybe (Set PackageName, DotPayload)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
name Map PackageName (Set PackageName, DotPayload)
dependencyMap of
Just (Set PackageName
deps, DotPayload
payload) -> do
ListDepsFormatOpts
-> DotOpts
-> Int
-> [Int]
-> Set PackageName
-> DotPayload
-> PackageName
-> IO ()
printTreeNode ListDepsFormatOpts
opts DotOpts
dotOpts Int
depth [Int]
newDepsCounts Set PackageName
deps DotPayload
payload PackageName
name
if Int -> Maybe Int
forall a. a -> Maybe a
Just Int
depth Maybe Int -> Maybe Int -> Bool
forall a. Eq a => a -> a -> Bool
== DotOpts -> Maybe Int
dotDependencyDepth DotOpts
dotOpts
then () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
else ListDepsFormatOpts
-> DotOpts
-> Int
-> [Int]
-> Set PackageName
-> Map PackageName (Set PackageName, DotPayload)
-> IO ()
printTree ListDepsFormatOpts
opts DotOpts
dotOpts (Int
depth Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [Int]
newDepsCounts Set PackageName
deps Map PackageName (Set PackageName, DotPayload)
dependencyMap
Maybe (Set PackageName, DotPayload)
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
printTreeNode :: ListDepsFormatOpts
-> DotOpts
-> Int
-> [Int]
-> Set PackageName
-> DotPayload
-> PackageName
-> IO ()
printTreeNode :: ListDepsFormatOpts
-> DotOpts
-> Int
-> [Int]
-> Set PackageName
-> DotPayload
-> PackageName
-> IO ()
printTreeNode ListDepsFormatOpts
opts DotOpts
dotOpts Int
depth [Int]
remainingDepsCounts Set PackageName
deps DotPayload
payload PackageName
name =
let remainingDepth :: Int
remainingDepth = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
999 (DotOpts -> Maybe Int
dotDependencyDepth DotOpts
dotOpts) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
depth
hasDeps :: Bool
hasDeps = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Set PackageName -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Set PackageName
deps
in Text -> IO ()
Text.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> [Int] -> Bool -> Int -> Text
treeNodePrefix Text
"" [Int]
remainingDepsCounts Bool
hasDeps Int
remainingDepth Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ListDepsFormatOpts -> PackageName -> DotPayload -> Text
listDepsLine ListDepsFormatOpts
opts PackageName
name DotPayload
payload
treeNodePrefix :: Text -> [Int] -> Bool -> Int -> Text
treeNodePrefix :: Text -> [Int] -> Bool -> Int -> Text
treeNodePrefix Text
t [] Bool
_ Int
_ = Text
t
treeNodePrefix Text
t [Int
0] Bool
True Int
0 = Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"└──"
treeNodePrefix Text
t [Int
_] Bool
True Int
0 = Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"├──"
treeNodePrefix Text
t [Int
0] Bool
True Int
_ = Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"└─┬"
treeNodePrefix Text
t [Int
_] Bool
True Int
_ = Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"├─┬"
treeNodePrefix Text
t [Int
0] Bool
False Int
_ = Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"└──"
treeNodePrefix Text
t [Int
_] Bool
False Int
_ = Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"├──"
treeNodePrefix Text
t (Int
0:[Int]
ns) Bool
d Int
remainingDepth = Text -> [Int] -> Bool -> Int -> Text
treeNodePrefix (Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ") [Int]
ns Bool
d Int
remainingDepth
treeNodePrefix Text
t (Int
_:[Int]
ns) Bool
d Int
remainingDepth = Text -> [Int] -> Bool -> Int -> Text
treeNodePrefix (Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"│ ") [Int]
ns Bool
d Int
remainingDepth
listDepsLine :: ListDepsFormatOpts -> PackageName -> DotPayload -> Text
listDepsLine :: ListDepsFormatOpts -> PackageName -> DotPayload -> Text
listDepsLine ListDepsFormatOpts
opts PackageName
name DotPayload
payload = String -> Text
Text.pack (PackageName -> String
packageNameString PackageName
name) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ListDepsFormatOpts -> Text
listDepsSep ListDepsFormatOpts
opts Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ListDepsFormatOpts -> DotPayload -> Text
payloadText ListDepsFormatOpts
opts DotPayload
payload
payloadText :: ListDepsFormatOpts -> DotPayload -> Text
payloadText :: ListDepsFormatOpts -> DotPayload -> Text
payloadText ListDepsFormatOpts
opts DotPayload
payload =
if ListDepsFormatOpts -> Bool
listDepsLicense ListDepsFormatOpts
opts
then DotPayload -> Text
licenseText DotPayload
payload
else DotPayload -> Text
versionText DotPayload
payload
licenseText :: DotPayload -> Text
licenseText :: DotPayload -> Text
licenseText DotPayload
payload = Text
-> (Either License License -> Text)
-> Maybe (Either License License)
-> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"<unknown>" (String -> Text
Text.pack (String -> Text)
-> (Either License License -> String)
-> Either License License
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. License -> String
forall a. Pretty a => a -> String
display (License -> String)
-> (Either License License -> License)
-> Either License License
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (License -> License)
-> (License -> License) -> Either License License -> License
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either License -> License
licenseFromSPDX License -> License
forall a. a -> a
id) (DotPayload -> Maybe (Either License License)
payloadLicense DotPayload
payload)
versionText :: DotPayload -> Text
versionText :: DotPayload -> Text
versionText DotPayload
payload = Text -> (Version -> Text) -> Maybe Version -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"<unknown>" (String -> Text
Text.pack (String -> Text) -> (Version -> String) -> Version -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> String
forall a. Pretty a => a -> String
display) (DotPayload -> Maybe Version
payloadVersion DotPayload
payload)
pruneGraph :: (F.Foldable f, F.Foldable g, Eq a)
=> f PackageName
-> g PackageName
-> Map PackageName (Set PackageName, a)
-> Map PackageName (Set PackageName, a)
pruneGraph :: f PackageName
-> g PackageName
-> Map PackageName (Set PackageName, a)
-> Map PackageName (Set PackageName, a)
pruneGraph f PackageName
dontPrune g PackageName
names =
f PackageName
-> Map PackageName (Set PackageName, a)
-> Map PackageName (Set PackageName, a)
forall a (f :: * -> *).
(Eq a, Foldable f) =>
f PackageName
-> Map PackageName (Set PackageName, a)
-> Map PackageName (Set PackageName, a)
pruneUnreachable f PackageName
dontPrune (Map PackageName (Set PackageName, a)
-> Map PackageName (Set PackageName, a))
-> (Map PackageName (Set PackageName, a)
-> Map PackageName (Set PackageName, a))
-> Map PackageName (Set PackageName, a)
-> Map PackageName (Set PackageName, a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PackageName -> (Set PackageName, a) -> Maybe (Set PackageName, a))
-> Map PackageName (Set PackageName, a)
-> Map PackageName (Set PackageName, a)
forall k a b. (k -> a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybeWithKey (\PackageName
pkg (Set PackageName
pkgDeps,a
x) ->
if PackageName
pkg PackageName -> g PackageName -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`F.elem` g PackageName
names
then Maybe (Set PackageName, a)
forall a. Maybe a
Nothing
else let filtered :: Set PackageName
filtered = (PackageName -> Bool) -> Set PackageName -> Set PackageName
forall a. (a -> Bool) -> Set a -> Set a
Set.filter (\PackageName
n -> PackageName
n PackageName -> g PackageName -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`F.notElem` g PackageName
names) Set PackageName
pkgDeps
in if Set PackageName -> Bool
forall a. Set a -> Bool
Set.null Set PackageName
filtered Bool -> Bool -> Bool
&& Bool -> Bool
not (Set PackageName -> Bool
forall a. Set a -> Bool
Set.null Set PackageName
pkgDeps)
then Maybe (Set PackageName, a)
forall a. Maybe a
Nothing
else (Set PackageName, a) -> Maybe (Set PackageName, a)
forall a. a -> Maybe a
Just (Set PackageName
filtered,a
x))
pruneUnreachable :: (Eq a, F.Foldable f)
=> f PackageName
-> Map PackageName (Set PackageName, a)
-> Map PackageName (Set PackageName, a)
pruneUnreachable :: f PackageName
-> Map PackageName (Set PackageName, a)
-> Map PackageName (Set PackageName, a)
pruneUnreachable f PackageName
dontPrune = (Map PackageName (Set PackageName, a)
-> Map PackageName (Set PackageName, a))
-> Map PackageName (Set PackageName, a)
-> Map PackageName (Set PackageName, a)
forall a. Eq a => (a -> a) -> a -> a
fixpoint Map PackageName (Set PackageName, a)
-> Map PackageName (Set PackageName, a)
forall b.
Map PackageName (Set PackageName, b)
-> Map PackageName (Set PackageName, b)
prune
where fixpoint :: Eq a => (a -> a) -> a -> a
fixpoint :: (a -> a) -> a -> a
fixpoint a -> a
f a
v = if a -> a
f a
v a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
v then a
v else (a -> a) -> a -> a
forall a. Eq a => (a -> a) -> a -> a
fixpoint a -> a
f (a -> a
f a
v)
prune :: Map PackageName (Set PackageName, b)
-> Map PackageName (Set PackageName, b)
prune Map PackageName (Set PackageName, b)
graph' = (PackageName -> (Set PackageName, b) -> Bool)
-> Map PackageName (Set PackageName, b)
-> Map PackageName (Set PackageName, b)
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey (\PackageName
k (Set PackageName, b)
_ -> PackageName -> Bool
reachable PackageName
k) Map PackageName (Set PackageName, b)
graph'
where reachable :: PackageName -> Bool
reachable PackageName
k = PackageName
k PackageName -> f PackageName -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`F.elem` f PackageName
dontPrune Bool -> Bool -> Bool
|| PackageName
k PackageName -> Set PackageName -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set PackageName
reachables
reachables :: Set PackageName
reachables = Map PackageName (Set PackageName) -> Set PackageName
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
F.fold ((Set PackageName, b) -> Set PackageName
forall a b. (a, b) -> a
fst ((Set PackageName, b) -> Set PackageName)
-> Map PackageName (Set PackageName, b)
-> Map PackageName (Set PackageName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map PackageName (Set PackageName, b)
graph')
resolveDependencies :: (Applicative m, Monad m)
=> Maybe Int
-> Map PackageName (Set PackageName, DotPayload)
-> (PackageName -> m (Set PackageName, DotPayload))
-> m (Map PackageName (Set PackageName, DotPayload))
resolveDependencies :: Maybe Int
-> Map PackageName (Set PackageName, DotPayload)
-> (PackageName -> m (Set PackageName, DotPayload))
-> m (Map PackageName (Set PackageName, DotPayload))
resolveDependencies (Just Int
0) Map PackageName (Set PackageName, DotPayload)
graph PackageName -> m (Set PackageName, DotPayload)
_ = Map PackageName (Set PackageName, DotPayload)
-> m (Map PackageName (Set PackageName, DotPayload))
forall (m :: * -> *) a. Monad m => a -> m a
return Map PackageName (Set PackageName, DotPayload)
graph
resolveDependencies Maybe Int
limit Map PackageName (Set PackageName, DotPayload)
graph PackageName -> m (Set PackageName, DotPayload)
loadPackageDeps = do
let values :: Set PackageName
values = [Set PackageName] -> Set PackageName
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions ((Set PackageName, DotPayload) -> Set PackageName
forall a b. (a, b) -> a
fst ((Set PackageName, DotPayload) -> Set PackageName)
-> [(Set PackageName, DotPayload)] -> [Set PackageName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map PackageName (Set PackageName, DotPayload)
-> [(Set PackageName, DotPayload)]
forall k a. Map k a -> [a]
Map.elems Map PackageName (Set PackageName, DotPayload)
graph)
keys :: Set PackageName
keys = Map PackageName (Set PackageName, DotPayload) -> Set PackageName
forall k a. Map k a -> Set k
Map.keysSet Map PackageName (Set PackageName, DotPayload)
graph
next :: Set PackageName
next = Set PackageName -> Set PackageName -> Set PackageName
forall a. Ord a => Set a -> Set a -> Set a
Set.difference Set PackageName
values Set PackageName
keys
if Set PackageName -> Bool
forall a. Set a -> Bool
Set.null Set PackageName
next
then Map PackageName (Set PackageName, DotPayload)
-> m (Map PackageName (Set PackageName, DotPayload))
forall (m :: * -> *) a. Monad m => a -> m a
return Map PackageName (Set PackageName, DotPayload)
graph
else do
[(PackageName, (Set PackageName, DotPayload))]
x <- (PackageName -> m (PackageName, (Set PackageName, DotPayload)))
-> [PackageName]
-> m [(PackageName, (Set PackageName, DotPayload))]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
T.traverse (\PackageName
name -> (PackageName
name,) ((Set PackageName, DotPayload)
-> (PackageName, (Set PackageName, DotPayload)))
-> m (Set PackageName, DotPayload)
-> m (PackageName, (Set PackageName, DotPayload))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PackageName -> m (Set PackageName, DotPayload)
loadPackageDeps PackageName
name) (Set PackageName -> [PackageName]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList Set PackageName
next)
Maybe Int
-> Map PackageName (Set PackageName, DotPayload)
-> (PackageName -> m (Set PackageName, DotPayload))
-> m (Map PackageName (Set PackageName, DotPayload))
forall (m :: * -> *).
(Applicative m, Monad m) =>
Maybe Int
-> Map PackageName (Set PackageName, DotPayload)
-> (PackageName -> m (Set PackageName, DotPayload))
-> m (Map PackageName (Set PackageName, DotPayload))
resolveDependencies (Int -> Int -> Int
forall a. Num a => a -> a -> a
subtract Int
1 (Int -> Int) -> Maybe Int -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Int
limit)
(((Set PackageName, DotPayload)
-> (Set PackageName, DotPayload) -> (Set PackageName, DotPayload))
-> Map PackageName (Set PackageName, DotPayload)
-> Map PackageName (Set PackageName, DotPayload)
-> Map PackageName (Set PackageName, DotPayload)
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith (Set PackageName, DotPayload)
-> (Set PackageName, DotPayload) -> (Set PackageName, DotPayload)
forall a b b. Ord a => (Set a, b) -> (Set a, b) -> (Set a, b)
unifier Map PackageName (Set PackageName, DotPayload)
graph ([(PackageName, (Set PackageName, DotPayload))]
-> Map PackageName (Set PackageName, DotPayload)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(PackageName, (Set PackageName, DotPayload))]
x))
PackageName -> m (Set PackageName, DotPayload)
loadPackageDeps
where unifier :: (Set a, b) -> (Set a, b) -> (Set a, b)
unifier (Set a
pkgs1,b
v1) (Set a
pkgs2,b
_) = (Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set a
pkgs1 Set a
pkgs2, b
v1)
createDepLoader :: SourceMap
-> Map PackageName DumpPackage
-> Map GhcPkgId PackageIdentifier
-> (PackageName -> Version -> PackageLocationImmutable ->
Map FlagName Bool -> [Text] -> [Text] -> RIO DotConfig (Set PackageName, DotPayload))
-> PackageName
-> RIO DotConfig (Set PackageName, DotPayload)
createDepLoader :: SourceMap
-> Map PackageName DumpPackage
-> Map GhcPkgId PackageIdentifier
-> (PackageName
-> Version
-> PackageLocationImmutable
-> Map FlagName Bool
-> [Text]
-> [Text]
-> RIO DotConfig (Set PackageName, DotPayload))
-> PackageName
-> RIO DotConfig (Set PackageName, DotPayload)
createDepLoader SourceMap
sourceMap Map PackageName DumpPackage
globalDumpMap Map GhcPkgId PackageIdentifier
globalIdMap PackageName
-> Version
-> PackageLocationImmutable
-> Map FlagName Bool
-> [Text]
-> [Text]
-> RIO DotConfig (Set PackageName, DotPayload)
loadPackageDeps PackageName
pkgName = do
RIO DotConfig (Set PackageName, DotPayload)
-> Maybe (RIO DotConfig (Set PackageName, DotPayload))
-> RIO DotConfig (Set PackageName, DotPayload)
forall a. a -> Maybe a -> a
fromMaybe RIO DotConfig (Set PackageName, DotPayload)
forall a. a
noDepsErr
(Maybe (RIO DotConfig (Set PackageName, DotPayload))
projectPackageDeps Maybe (RIO DotConfig (Set PackageName, DotPayload))
-> Maybe (RIO DotConfig (Set PackageName, DotPayload))
-> Maybe (RIO DotConfig (Set PackageName, DotPayload))
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe (RIO DotConfig (Set PackageName, DotPayload))
dependencyDeps Maybe (RIO DotConfig (Set PackageName, DotPayload))
-> Maybe (RIO DotConfig (Set PackageName, DotPayload))
-> Maybe (RIO DotConfig (Set PackageName, DotPayload))
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe (RIO DotConfig (Set PackageName, DotPayload))
globalDeps)
where
projectPackageDeps :: Maybe (RIO DotConfig (Set PackageName, DotPayload))
projectPackageDeps =
ProjectPackage -> RIO DotConfig (Set PackageName, DotPayload)
forall env.
(HasBuildConfig env, HasSourceMap env) =>
ProjectPackage -> RIO env (Set PackageName, DotPayload)
loadDeps (ProjectPackage -> RIO DotConfig (Set PackageName, DotPayload))
-> Maybe ProjectPackage
-> Maybe (RIO DotConfig (Set PackageName, DotPayload))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PackageName
-> Map PackageName ProjectPackage -> Maybe ProjectPackage
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
pkgName (SourceMap -> Map PackageName ProjectPackage
smProject SourceMap
sourceMap)
where
loadDeps :: ProjectPackage -> RIO env (Set PackageName, DotPayload)
loadDeps ProjectPackage
pp = do
Package
pkg <- CommonPackage -> RIO env Package
forall env.
(HasBuildConfig env, HasSourceMap env) =>
CommonPackage -> RIO env Package
loadCommonPackage (ProjectPackage -> CommonPackage
ppCommon ProjectPackage
pp)
(Set PackageName, DotPayload)
-> RIO env (Set PackageName, DotPayload)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Package -> Set PackageName
packageAllDeps Package
pkg, Package -> Maybe PackageLocation -> DotPayload
payloadFromLocal Package
pkg Maybe PackageLocation
forall a. Maybe a
Nothing)
dependencyDeps :: Maybe (RIO DotConfig (Set PackageName, DotPayload))
dependencyDeps =
DepPackage -> RIO DotConfig (Set PackageName, DotPayload)
loadDeps (DepPackage -> RIO DotConfig (Set PackageName, DotPayload))
-> Maybe DepPackage
-> Maybe (RIO DotConfig (Set PackageName, DotPayload))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PackageName -> Map PackageName DepPackage -> Maybe DepPackage
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
pkgName (SourceMap -> Map PackageName DepPackage
smDeps SourceMap
sourceMap)
where
loadDeps :: DepPackage -> RIO DotConfig (Set PackageName, DotPayload)
loadDeps DepPackage{dpLocation :: DepPackage -> PackageLocation
dpLocation=PLMutable ResolvedPath Dir
dir} = do
ProjectPackage
pp <- PrintWarnings
-> ResolvedPath Dir -> Bool -> RIO DotConfig ProjectPackage
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
PrintWarnings -> ResolvedPath Dir -> Bool -> RIO env ProjectPackage
mkProjectPackage PrintWarnings
YesPrintWarnings ResolvedPath Dir
dir Bool
False
Package
pkg <- CommonPackage -> RIO DotConfig Package
forall env.
(HasBuildConfig env, HasSourceMap env) =>
CommonPackage -> RIO env Package
loadCommonPackage (ProjectPackage -> CommonPackage
ppCommon ProjectPackage
pp)
(Set PackageName, DotPayload)
-> RIO DotConfig (Set PackageName, DotPayload)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Package -> Set PackageName
packageAllDeps Package
pkg, Package -> Maybe PackageLocation -> DotPayload
payloadFromLocal Package
pkg (PackageLocation -> Maybe PackageLocation
forall a. a -> Maybe a
Just (PackageLocation -> Maybe PackageLocation)
-> PackageLocation -> Maybe PackageLocation
forall a b. (a -> b) -> a -> b
$ ResolvedPath Dir -> PackageLocation
PLMutable ResolvedPath Dir
dir))
loadDeps dp :: DepPackage
dp@DepPackage{dpLocation :: DepPackage -> PackageLocation
dpLocation=PLImmutable PackageLocationImmutable
loc} = do
let common :: CommonPackage
common = DepPackage -> CommonPackage
dpCommon DepPackage
dp
GenericPackageDescription
gpd <- IO GenericPackageDescription
-> RIO DotConfig GenericPackageDescription
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO GenericPackageDescription
-> RIO DotConfig GenericPackageDescription)
-> IO GenericPackageDescription
-> RIO DotConfig GenericPackageDescription
forall a b. (a -> b) -> a -> b
$ CommonPackage -> IO GenericPackageDescription
cpGPD CommonPackage
common
let PackageIdentifier PackageName
name Version
version = PackageDescription -> PackageIdentifier
PD.package (PackageDescription -> PackageIdentifier)
-> PackageDescription -> PackageIdentifier
forall a b. (a -> b) -> a -> b
$ GenericPackageDescription -> PackageDescription
PD.packageDescription GenericPackageDescription
gpd
flags :: Map FlagName Bool
flags = CommonPackage -> Map FlagName Bool
cpFlags CommonPackage
common
ghcOptions :: [Text]
ghcOptions = CommonPackage -> [Text]
cpGhcOptions CommonPackage
common
cabalConfigOpts :: [Text]
cabalConfigOpts = CommonPackage -> [Text]
cpCabalConfigOpts CommonPackage
common
Bool
-> RIO DotConfig (Set PackageName, DotPayload)
-> RIO DotConfig (Set PackageName, DotPayload)
forall a. HasCallStack => Bool -> a -> a
assert (PackageName
pkgName PackageName -> PackageName -> Bool
forall a. Eq a => a -> a -> Bool
== PackageName
name) (PackageName
-> Version
-> PackageLocationImmutable
-> Map FlagName Bool
-> [Text]
-> [Text]
-> RIO DotConfig (Set PackageName, DotPayload)
loadPackageDeps PackageName
pkgName Version
version PackageLocationImmutable
loc Map FlagName Bool
flags [Text]
ghcOptions [Text]
cabalConfigOpts)
globalDeps :: Maybe (RIO DotConfig (Set PackageName, DotPayload))
globalDeps =
(Set PackageName, DotPayload)
-> RIO DotConfig (Set PackageName, DotPayload)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Set PackageName, DotPayload)
-> RIO DotConfig (Set PackageName, DotPayload))
-> (DumpPackage -> (Set PackageName, DotPayload))
-> DumpPackage
-> RIO DotConfig (Set PackageName, DotPayload)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DumpPackage -> (Set PackageName, DotPayload)
getDepsFromDump (DumpPackage -> RIO DotConfig (Set PackageName, DotPayload))
-> Maybe DumpPackage
-> Maybe (RIO DotConfig (Set PackageName, DotPayload))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PackageName -> Map PackageName DumpPackage -> Maybe DumpPackage
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
pkgName Map PackageName DumpPackage
globalDumpMap
where
getDepsFromDump :: DumpPackage -> (Set PackageName, DotPayload)
getDepsFromDump DumpPackage
dump =
([PackageName] -> Set PackageName
forall a. Ord a => [a] -> Set a
Set.fromList [PackageName]
deps, DumpPackage -> DotPayload
payloadFromDump DumpPackage
dump)
where
deps :: [PackageName]
deps = (GhcPkgId -> PackageName) -> [GhcPkgId] -> [PackageName]
forall a b. (a -> b) -> [a] -> [b]
map GhcPkgId -> PackageName
ghcIdToPackageName (DumpPackage -> [GhcPkgId]
dpDepends DumpPackage
dump)
ghcIdToPackageName :: GhcPkgId -> PackageName
ghcIdToPackageName GhcPkgId
depId =
let errText :: String
errText = String
"Invariant violated: Expected to find "
in PackageName
-> (PackageIdentifier -> PackageName)
-> Maybe PackageIdentifier
-> PackageName
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> PackageName
forall a. HasCallStack => String -> a
error (String
errText String -> ShowS
forall a. [a] -> [a] -> [a]
++ GhcPkgId -> String
ghcPkgIdString GhcPkgId
depId String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" in global DB"))
PackageIdentifier -> PackageName
Stack.Prelude.pkgName
(GhcPkgId
-> Map GhcPkgId PackageIdentifier -> Maybe PackageIdentifier
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup GhcPkgId
depId Map GhcPkgId PackageIdentifier
globalIdMap)
noDepsErr :: a
noDepsErr = String -> a
forall a. HasCallStack => String -> a
error (String
"Invariant violated: The '" String -> ShowS
forall a. [a] -> [a] -> [a]
++ PackageName -> String
packageNameString PackageName
pkgName
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"' package was not found in any of the dependency sources")
payloadFromLocal :: Package -> Maybe PackageLocation -> DotPayload
payloadFromLocal Package
pkg Maybe PackageLocation
loc = Maybe Version
-> Maybe (Either License License)
-> Maybe PackageLocation
-> DotPayload
DotPayload (Version -> Maybe Version
forall a. a -> Maybe a
Just (Version -> Maybe Version) -> Version -> Maybe Version
forall a b. (a -> b) -> a -> b
$ Package -> Version
packageVersion Package
pkg) (Either License License -> Maybe (Either License License)
forall a. a -> Maybe a
Just (Either License License -> Maybe (Either License License))
-> Either License License -> Maybe (Either License License)
forall a b. (a -> b) -> a -> b
$ Package -> Either License License
packageLicense Package
pkg) Maybe PackageLocation
loc
payloadFromDump :: DumpPackage -> DotPayload
payloadFromDump DumpPackage
dp = Maybe Version
-> Maybe (Either License License)
-> Maybe PackageLocation
-> DotPayload
DotPayload (Version -> Maybe Version
forall a. a -> Maybe a
Just (Version -> Maybe Version) -> Version -> Maybe Version
forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> Version
pkgVersion (PackageIdentifier -> Version) -> PackageIdentifier -> Version
forall a b. (a -> b) -> a -> b
$ DumpPackage -> PackageIdentifier
dpPackageIdent DumpPackage
dp) (License -> Either License License
forall a b. b -> Either a b
Right (License -> Either License License)
-> Maybe License -> Maybe (Either License License)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DumpPackage -> Maybe License
dpLicense DumpPackage
dp) Maybe PackageLocation
forall a. Maybe a
Nothing
projectPackageDependencies :: DotOpts -> [LocalPackage] -> [(PackageName, (Set PackageName, DotPayload))]
projectPackageDependencies :: DotOpts
-> [LocalPackage] -> [(PackageName, (Set PackageName, DotPayload))]
projectPackageDependencies DotOpts
dotOpts [LocalPackage]
locals =
(LocalPackage -> (PackageName, (Set PackageName, DotPayload)))
-> [LocalPackage] -> [(PackageName, (Set PackageName, DotPayload))]
forall a b. (a -> b) -> [a] -> [b]
map (\LocalPackage
lp -> let pkg :: Package
pkg = LocalPackage -> Package
localPackageToPackage LocalPackage
lp
pkgDir :: Path Abs Dir
pkgDir = Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
Path.parent (Path Abs File -> Path Abs Dir) -> Path Abs File -> Path Abs Dir
forall a b. (a -> b) -> a -> b
$ LocalPackage -> Path Abs File
lpCabalFile LocalPackage
lp
loc :: PackageLocation
loc = ResolvedPath Dir -> PackageLocation
PLMutable (ResolvedPath Dir -> PackageLocation)
-> ResolvedPath Dir -> PackageLocation
forall a b. (a -> b) -> a -> b
$ RelFilePath -> Path Abs Dir -> ResolvedPath Dir
forall t. RelFilePath -> Path Abs t -> ResolvedPath t
ResolvedPath (Text -> RelFilePath
RelFilePath Text
"N/A") Path Abs Dir
pkgDir
in (Package -> PackageName
packageName Package
pkg, (Package -> Set PackageName
deps Package
pkg, Package -> PackageLocation -> DotPayload
lpPayload Package
pkg PackageLocation
loc)))
[LocalPackage]
locals
where deps :: Package -> Set PackageName
deps Package
pkg =
if DotOpts -> Bool
dotIncludeExternal DotOpts
dotOpts
then PackageName -> Set PackageName -> Set PackageName
forall a. Ord a => a -> Set a -> Set a
Set.delete (Package -> PackageName
packageName Package
pkg) (Package -> Set PackageName
packageAllDeps Package
pkg)
else Set PackageName -> Set PackageName -> Set PackageName
forall a. Ord a => Set a -> Set a -> Set a
Set.intersection Set PackageName
localNames (Package -> Set PackageName
packageAllDeps Package
pkg)
localNames :: Set PackageName
localNames = [PackageName] -> Set PackageName
forall a. Ord a => [a] -> Set a
Set.fromList ([PackageName] -> Set PackageName)
-> [PackageName] -> Set PackageName
forall a b. (a -> b) -> a -> b
$ (LocalPackage -> PackageName) -> [LocalPackage] -> [PackageName]
forall a b. (a -> b) -> [a] -> [b]
map (Package -> PackageName
packageName (Package -> PackageName)
-> (LocalPackage -> Package) -> LocalPackage -> PackageName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocalPackage -> Package
lpPackage) [LocalPackage]
locals
lpPayload :: Package -> PackageLocation -> DotPayload
lpPayload Package
pkg PackageLocation
loc = Maybe Version
-> Maybe (Either License License)
-> Maybe PackageLocation
-> DotPayload
DotPayload (Version -> Maybe Version
forall a. a -> Maybe a
Just (Version -> Maybe Version) -> Version -> Maybe Version
forall a b. (a -> b) -> a -> b
$ Package -> Version
packageVersion Package
pkg) (Either License License -> Maybe (Either License License)
forall a. a -> Maybe a
Just (Either License License -> Maybe (Either License License))
-> Either License License -> Maybe (Either License License)
forall a b. (a -> b) -> a -> b
$ Package -> Either License License
packageLicense Package
pkg) (PackageLocation -> Maybe PackageLocation
forall a. a -> Maybe a
Just PackageLocation
loc)
printGraph :: (Applicative m, MonadIO m)
=> DotOpts
-> Set PackageName
-> Map PackageName (Set PackageName, DotPayload)
-> m ()
printGraph :: DotOpts
-> Set PackageName
-> Map PackageName (Set PackageName, DotPayload)
-> m ()
printGraph DotOpts
dotOpts Set PackageName
locals Map PackageName (Set PackageName, DotPayload)
graph = do
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
Text.putStrLn Text
"strict digraph deps {"
DotOpts -> Set PackageName -> m ()
forall (t :: * -> *) (m :: * -> *).
(Foldable t, MonadIO m) =>
DotOpts -> t PackageName -> m ()
printLocalNodes DotOpts
dotOpts Set PackageName
filteredLocals
Map PackageName (Set PackageName, DotPayload) -> m ()
forall (m :: * -> *).
MonadIO m =>
Map PackageName (Set PackageName, DotPayload) -> m ()
printLeaves Map PackageName (Set PackageName, DotPayload)
graph
m (Map PackageName ()) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ((PackageName -> Set PackageName -> m ())
-> Map PackageName (Set PackageName) -> m (Map PackageName ())
forall (t :: * -> *) k a b.
Applicative t =>
(k -> a -> t b) -> Map k a -> t (Map k b)
Map.traverseWithKey PackageName -> Set PackageName -> m ()
forall (m :: * -> *).
MonadIO m =>
PackageName -> Set PackageName -> m ()
printEdges ((Set PackageName, DotPayload) -> Set PackageName
forall a b. (a, b) -> a
fst ((Set PackageName, DotPayload) -> Set PackageName)
-> Map PackageName (Set PackageName, DotPayload)
-> Map PackageName (Set PackageName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map PackageName (Set PackageName, DotPayload)
graph))
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
Text.putStrLn Text
"}"
where filteredLocals :: Set PackageName
filteredLocals = (PackageName -> Bool) -> Set PackageName -> Set PackageName
forall a. (a -> Bool) -> Set a -> Set a
Set.filter (\PackageName
local' ->
PackageName
local' PackageName -> Set PackageName -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` DotOpts -> Set PackageName
dotPrune DotOpts
dotOpts) Set PackageName
locals
printLocalNodes :: (F.Foldable t, MonadIO m)
=> DotOpts
-> t PackageName
-> m ()
printLocalNodes :: DotOpts -> t PackageName -> m ()
printLocalNodes DotOpts
dotOpts t PackageName
locals = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
Text.putStrLn (Text -> [Text] -> Text
Text.intercalate Text
"\n" [Text]
lpNodes)
where applyStyle :: Text -> Text
applyStyle :: Text -> Text
applyStyle Text
n = if DotOpts -> Bool
dotIncludeExternal DotOpts
dotOpts
then Text
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" [style=dashed];"
else Text
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" [style=solid];"
lpNodes :: [Text]
lpNodes :: [Text]
lpNodes = (PackageName -> Text) -> [PackageName] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Text
applyStyle (Text -> Text) -> (PackageName -> Text) -> PackageName -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> Text
nodeName) (t PackageName -> [PackageName]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList t PackageName
locals)
printLeaves :: MonadIO m
=> Map PackageName (Set PackageName, DotPayload)
-> m ()
printLeaves :: Map PackageName (Set PackageName, DotPayload) -> m ()
printLeaves = (PackageName -> m ()) -> Set PackageName -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
F.mapM_ PackageName -> m ()
forall (m :: * -> *). MonadIO m => PackageName -> m ()
printLeaf (Set PackageName -> m ())
-> (Map PackageName (Set PackageName, DotPayload)
-> Set PackageName)
-> Map PackageName (Set PackageName, DotPayload)
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map PackageName (Set PackageName) -> Set PackageName
forall k a. Map k a -> Set k
Map.keysSet (Map PackageName (Set PackageName) -> Set PackageName)
-> (Map PackageName (Set PackageName, DotPayload)
-> Map PackageName (Set PackageName))
-> Map PackageName (Set PackageName, DotPayload)
-> Set PackageName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set PackageName -> Bool)
-> Map PackageName (Set PackageName)
-> Map PackageName (Set PackageName)
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter Set PackageName -> Bool
forall a. Set a -> Bool
Set.null (Map PackageName (Set PackageName)
-> Map PackageName (Set PackageName))
-> (Map PackageName (Set PackageName, DotPayload)
-> Map PackageName (Set PackageName))
-> Map PackageName (Set PackageName, DotPayload)
-> Map PackageName (Set PackageName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Set PackageName, DotPayload) -> Set PackageName)
-> Map PackageName (Set PackageName, DotPayload)
-> Map PackageName (Set PackageName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Set PackageName, DotPayload) -> Set PackageName
forall a b. (a, b) -> a
fst
printEdges :: MonadIO m => PackageName -> Set PackageName -> m ()
printEdges :: PackageName -> Set PackageName -> m ()
printEdges PackageName
package Set PackageName
deps = Set PackageName -> (PackageName -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
F.forM_ Set PackageName
deps (PackageName -> PackageName -> m ()
forall (m :: * -> *).
MonadIO m =>
PackageName -> PackageName -> m ()
printEdge PackageName
package)
printEdge :: MonadIO m => PackageName -> PackageName -> m ()
printEdge :: PackageName -> PackageName -> m ()
printEdge PackageName
from PackageName
to' = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
Text.putStrLn ([Text] -> Text
Text.concat [ PackageName -> Text
nodeName PackageName
from, Text
" -> ", PackageName -> Text
nodeName PackageName
to', Text
";"])
nodeName :: PackageName -> Text
nodeName :: PackageName -> Text
nodeName PackageName
name = Text
"\"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (PackageName -> String
packageNameString PackageName
name) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\""
printLeaf :: MonadIO m => PackageName -> m ()
printLeaf :: PackageName -> m ()
printLeaf PackageName
package = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> ([Text] -> IO ()) -> [Text] -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> IO ()
Text.putStrLn (Text -> IO ()) -> ([Text] -> Text) -> [Text] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
Text.concat ([Text] -> m ()) -> [Text] -> m ()
forall a b. (a -> b) -> a -> b
$
if PackageName -> Bool
isWiredIn PackageName
package
then [Text
"{rank=max; ", PackageName -> Text
nodeName PackageName
package, Text
" [shape=box]; };"]
else [Text
"{rank=max; ", PackageName -> Text
nodeName PackageName
package, Text
"; };"]
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)
withDotConfig
:: DotOpts
-> RIO DotConfig a
-> RIO Runner a
withDotConfig :: DotOpts -> RIO DotConfig a -> RIO Runner a
withDotConfig DotOpts
opts RIO DotConfig a
inner =
(Runner -> Runner) -> RIO Runner a -> RIO Runner a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (ASetter Runner Runner GlobalOpts GlobalOpts
-> (GlobalOpts -> GlobalOpts) -> Runner -> Runner
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter Runner Runner GlobalOpts GlobalOpts
forall env. HasRunner env => Lens' env GlobalOpts
globalOptsL GlobalOpts -> GlobalOpts
modifyGO) (RIO Runner a -> RIO Runner a) -> RIO Runner a -> RIO Runner a
forall a b. (a -> b) -> a -> b
$
if DotOpts -> Bool
dotGlobalHints DotOpts
opts
then ShouldReexec -> RIO Config a -> RIO Runner a
forall a. ShouldReexec -> RIO Config a -> RIO Runner a
withConfig ShouldReexec
NoReexec (RIO Config a -> RIO Runner a) -> RIO Config a -> RIO Runner a
forall a b. (a -> b) -> a -> b
$ RIO BuildConfig a -> RIO Config a
forall a. RIO BuildConfig a -> RIO Config a
withBuildConfig RIO BuildConfig a
withGlobalHints
else ShouldReexec -> RIO Config a -> RIO Runner a
forall a. ShouldReexec -> RIO Config a -> RIO Runner a
withConfig ShouldReexec
YesReexec RIO Config a
withReal
where
withGlobalHints :: RIO BuildConfig a
withGlobalHints = do
BuildConfig
bconfig <- Getting BuildConfig BuildConfig BuildConfig
-> RIO BuildConfig BuildConfig
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting BuildConfig BuildConfig BuildConfig
forall env. HasBuildConfig env => Lens' env BuildConfig
buildConfigL
Map PackageName Version
globals <- WantedCompiler -> RIO BuildConfig (Map PackageName Version)
forall env.
HasConfig env =>
WantedCompiler -> RIO env (Map PackageName Version)
globalsFromHints (WantedCompiler -> RIO BuildConfig (Map PackageName Version))
-> WantedCompiler -> RIO BuildConfig (Map PackageName Version)
forall a b. (a -> b) -> a -> b
$ SMWanted -> WantedCompiler
smwCompiler (SMWanted -> WantedCompiler) -> SMWanted -> WantedCompiler
forall a b. (a -> b) -> a -> b
$ BuildConfig -> SMWanted
bcSMWanted BuildConfig
bconfig
GhcPkgId
fakeGhcPkgId <- Text -> RIO BuildConfig GhcPkgId
forall (m :: * -> *). MonadThrow m => Text -> m GhcPkgId
parseGhcPkgId Text
"ignored"
ActualCompiler
actual <- (CompilerException -> RIO BuildConfig ActualCompiler)
-> (ActualCompiler -> RIO BuildConfig ActualCompiler)
-> Either CompilerException ActualCompiler
-> RIO BuildConfig ActualCompiler
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either CompilerException -> RIO BuildConfig ActualCompiler
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO ActualCompiler -> RIO BuildConfig ActualCompiler
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either CompilerException ActualCompiler
-> RIO BuildConfig ActualCompiler)
-> Either CompilerException ActualCompiler
-> RIO BuildConfig ActualCompiler
forall a b. (a -> b) -> a -> b
$
WantedCompiler -> Either CompilerException ActualCompiler
wantedToActual (WantedCompiler -> Either CompilerException ActualCompiler)
-> WantedCompiler -> Either CompilerException ActualCompiler
forall a b. (a -> b) -> a -> b
$ SMWanted -> WantedCompiler
smwCompiler (SMWanted -> WantedCompiler) -> SMWanted -> WantedCompiler
forall a b. (a -> b) -> a -> b
$
BuildConfig -> SMWanted
bcSMWanted BuildConfig
bconfig
let smActual :: SMActual DumpPackage
smActual = SMActual :: forall global.
ActualCompiler
-> Map PackageName ProjectPackage
-> Map PackageName DepPackage
-> Map PackageName global
-> SMActual global
SMActual
{ smaCompiler :: ActualCompiler
smaCompiler = ActualCompiler
actual
, smaProject :: Map PackageName ProjectPackage
smaProject = SMWanted -> Map PackageName ProjectPackage
smwProject (SMWanted -> Map PackageName ProjectPackage)
-> SMWanted -> Map PackageName ProjectPackage
forall a b. (a -> b) -> a -> b
$ BuildConfig -> SMWanted
bcSMWanted BuildConfig
bconfig
, smaDeps :: Map PackageName DepPackage
smaDeps = SMWanted -> Map PackageName DepPackage
smwDeps (SMWanted -> Map PackageName DepPackage)
-> SMWanted -> Map PackageName DepPackage
forall a b. (a -> b) -> a -> b
$ BuildConfig -> SMWanted
bcSMWanted BuildConfig
bconfig
, smaGlobal :: Map PackageName DumpPackage
smaGlobal = (PackageName -> Version -> DumpPackage)
-> Map PackageName Version -> Map PackageName DumpPackage
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey PackageName -> Version -> DumpPackage
toDump Map PackageName Version
globals
}
toDump :: PackageName -> Version -> DumpPackage
toDump :: PackageName -> Version -> DumpPackage
toDump PackageName
name Version
version = DumpPackage :: GhcPkgId
-> PackageIdentifier
-> Maybe PackageIdentifier
-> Maybe License
-> [String]
-> [Text]
-> Bool
-> Set ModuleName
-> [GhcPkgId]
-> [String]
-> Maybe String
-> Bool
-> DumpPackage
DumpPackage
{ dpGhcPkgId :: GhcPkgId
dpGhcPkgId = GhcPkgId
fakeGhcPkgId
, dpPackageIdent :: PackageIdentifier
dpPackageIdent = PackageName -> Version -> PackageIdentifier
PackageIdentifier PackageName
name Version
version
, dpParentLibIdent :: Maybe PackageIdentifier
dpParentLibIdent = Maybe PackageIdentifier
forall a. Maybe a
Nothing
, dpLicense :: Maybe License
dpLicense = Maybe License
forall a. Maybe a
Nothing
, dpLibDirs :: [String]
dpLibDirs = []
, dpLibraries :: [Text]
dpLibraries = []
, dpHasExposedModules :: Bool
dpHasExposedModules = Bool
True
, dpExposedModules :: Set ModuleName
dpExposedModules = Set ModuleName
forall a. Monoid a => a
mempty
, dpDepends :: [GhcPkgId]
dpDepends = []
, dpHaddockInterfaces :: [String]
dpHaddockInterfaces = []
, dpHaddockHtml :: Maybe String
dpHaddockHtml = Maybe String
forall a. Maybe a
Nothing
, dpIsExposed :: Bool
dpIsExposed = Bool
True
}
actualPkgs :: Set PackageName
actualPkgs = Map PackageName DepPackage -> Set PackageName
forall k a. Map k a -> Set k
Map.keysSet (SMActual DumpPackage -> Map PackageName DepPackage
forall global. SMActual global -> Map PackageName DepPackage
smaDeps SMActual DumpPackage
smActual) Set PackageName -> Set PackageName -> Set PackageName
forall a. Semigroup a => a -> a -> a
<>
Map PackageName ProjectPackage -> Set PackageName
forall k a. Map k a -> Set k
Map.keysSet (SMActual DumpPackage -> Map PackageName ProjectPackage
forall global. SMActual global -> Map PackageName ProjectPackage
smaProject SMActual DumpPackage
smActual)
prunedActual :: SMActual GlobalPackage
prunedActual = SMActual DumpPackage
smActual { smaGlobal :: Map PackageName GlobalPackage
smaGlobal = Map PackageName DumpPackage
-> Set PackageName -> Map PackageName GlobalPackage
pruneGlobals (SMActual DumpPackage -> Map PackageName DumpPackage
forall global. SMActual global -> Map PackageName global
smaGlobal SMActual DumpPackage
smActual) Set PackageName
actualPkgs }
SMTargets
targets <- NeedTargets
-> Bool
-> BuildOptsCLI
-> SMActual GlobalPackage
-> RIO BuildConfig SMTargets
forall env.
HasBuildConfig env =>
NeedTargets
-> Bool
-> BuildOptsCLI
-> SMActual GlobalPackage
-> RIO env SMTargets
parseTargets NeedTargets
NeedTargets Bool
False BuildOptsCLI
boptsCLI SMActual GlobalPackage
prunedActual
Utf8Builder -> RIO BuildConfig ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Loading source map"
SourceMap
sourceMap <- SMTargets
-> BuildOptsCLI
-> SMActual DumpPackage
-> RIO BuildConfig SourceMap
forall env.
HasBuildConfig env =>
SMTargets
-> BuildOptsCLI -> SMActual DumpPackage -> RIO env SourceMap
loadSourceMap SMTargets
targets BuildOptsCLI
boptsCLI SMActual DumpPackage
smActual
let dc :: DotConfig
dc = DotConfig :: BuildConfig -> SourceMap -> [DumpPackage] -> DotConfig
DotConfig
{ dcBuildConfig :: BuildConfig
dcBuildConfig = BuildConfig
bconfig
, dcSourceMap :: SourceMap
dcSourceMap = SourceMap
sourceMap
, dcGlobalDump :: [DumpPackage]
dcGlobalDump = Map PackageName DumpPackage -> [DumpPackage]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Map PackageName DumpPackage -> [DumpPackage])
-> Map PackageName DumpPackage -> [DumpPackage]
forall a b. (a -> b) -> a -> b
$ SMActual DumpPackage -> Map PackageName DumpPackage
forall global. SMActual global -> Map PackageName global
smaGlobal SMActual DumpPackage
smActual
}
Utf8Builder -> RIO BuildConfig ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"DotConfig fully loaded"
DotConfig -> RIO DotConfig a -> RIO BuildConfig a
forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO DotConfig
dc RIO DotConfig a
inner
withReal :: RIO Config a
withReal = NeedTargets -> BuildOptsCLI -> RIO EnvConfig a -> RIO Config a
forall a.
NeedTargets -> BuildOptsCLI -> RIO EnvConfig a -> RIO Config a
withEnvConfig NeedTargets
NeedTargets BuildOptsCLI
boptsCLI (RIO EnvConfig a -> RIO Config a)
-> RIO EnvConfig a -> RIO Config a
forall a b. (a -> b) -> a -> b
$ do
EnvConfig
envConfig <- RIO EnvConfig EnvConfig
forall r (m :: * -> *). MonadReader r m => m r
ask
let sourceMap :: SourceMap
sourceMap = EnvConfig -> SourceMap
envConfigSourceMap EnvConfig
envConfig
InstallMap
installMap <- SourceMap -> RIO EnvConfig InstallMap
forall (m :: * -> *). MonadIO m => SourceMap -> m InstallMap
toInstallMap SourceMap
sourceMap
(InstalledMap
_, [DumpPackage]
globalDump, [DumpPackage]
_, [DumpPackage]
_) <- InstallMap
-> RIO
EnvConfig
(InstalledMap, [DumpPackage], [DumpPackage], [DumpPackage])
forall env.
HasEnvConfig env =>
InstallMap
-> RIO
env (InstalledMap, [DumpPackage], [DumpPackage], [DumpPackage])
getInstalled InstallMap
installMap
let dc :: DotConfig
dc = DotConfig :: BuildConfig -> SourceMap -> [DumpPackage] -> DotConfig
DotConfig
{ dcBuildConfig :: BuildConfig
dcBuildConfig = EnvConfig -> BuildConfig
envConfigBuildConfig EnvConfig
envConfig
, dcSourceMap :: SourceMap
dcSourceMap = SourceMap
sourceMap
, dcGlobalDump :: [DumpPackage]
dcGlobalDump = [DumpPackage]
globalDump
}
DotConfig -> RIO DotConfig a -> RIO EnvConfig a
forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO DotConfig
dc RIO DotConfig a
inner
boptsCLI :: BuildOptsCLI
boptsCLI = BuildOptsCLI
defaultBuildOptsCLI
{ boptsCLITargets :: [Text]
boptsCLITargets = DotOpts -> [Text]
dotTargets DotOpts
opts
, boptsCLIFlags :: Map ApplyCLIFlag (Map FlagName Bool)
boptsCLIFlags = DotOpts -> Map ApplyCLIFlag (Map FlagName Bool)
dotFlags DotOpts
opts
}
modifyGO :: GlobalOpts -> GlobalOpts
modifyGO =
(if DotOpts -> Bool
dotTestTargets DotOpts
opts then ASetter GlobalOpts GlobalOpts (Maybe Bool) (Maybe Bool)
-> Maybe Bool -> GlobalOpts -> GlobalOpts
forall s t a b. ASetter s t a b -> b -> s -> t
set ((BuildOptsMonoid -> Identity BuildOptsMonoid)
-> GlobalOpts -> Identity GlobalOpts
Lens' GlobalOpts BuildOptsMonoid
globalOptsBuildOptsMonoidL((BuildOptsMonoid -> Identity BuildOptsMonoid)
-> GlobalOpts -> Identity GlobalOpts)
-> ((Maybe Bool -> Identity (Maybe Bool))
-> BuildOptsMonoid -> Identity BuildOptsMonoid)
-> ASetter GlobalOpts GlobalOpts (Maybe Bool) (Maybe Bool)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Maybe Bool -> Identity (Maybe Bool))
-> BuildOptsMonoid -> Identity BuildOptsMonoid
Lens' BuildOptsMonoid (Maybe Bool)
buildOptsMonoidTestsL) (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True) else GlobalOpts -> GlobalOpts
forall a. a -> a
id) (GlobalOpts -> GlobalOpts)
-> (GlobalOpts -> GlobalOpts) -> GlobalOpts -> GlobalOpts
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
(if DotOpts -> Bool
dotBenchTargets DotOpts
opts then ASetter GlobalOpts GlobalOpts (Maybe Bool) (Maybe Bool)
-> Maybe Bool -> GlobalOpts -> GlobalOpts
forall s t a b. ASetter s t a b -> b -> s -> t
set ((BuildOptsMonoid -> Identity BuildOptsMonoid)
-> GlobalOpts -> Identity GlobalOpts
Lens' GlobalOpts BuildOptsMonoid
globalOptsBuildOptsMonoidL((BuildOptsMonoid -> Identity BuildOptsMonoid)
-> GlobalOpts -> Identity GlobalOpts)
-> ((Maybe Bool -> Identity (Maybe Bool))
-> BuildOptsMonoid -> Identity BuildOptsMonoid)
-> ASetter GlobalOpts GlobalOpts (Maybe Bool) (Maybe Bool)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Maybe Bool -> Identity (Maybe Bool))
-> BuildOptsMonoid -> Identity BuildOptsMonoid
Lens' BuildOptsMonoid (Maybe Bool)
buildOptsMonoidBenchmarksL) (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True) else GlobalOpts -> GlobalOpts
forall a. a -> a
id)
data DotConfig = DotConfig
{ DotConfig -> BuildConfig
dcBuildConfig :: !BuildConfig
, DotConfig -> SourceMap
dcSourceMap :: !SourceMap
, DotConfig -> [DumpPackage]
dcGlobalDump :: ![DumpPackage]
}
instance HasLogFunc DotConfig where
logFuncL :: (LogFunc -> f LogFunc) -> DotConfig -> f DotConfig
logFuncL = (Runner -> f Runner) -> DotConfig -> f DotConfig
forall env. HasRunner env => Lens' env Runner
runnerL((Runner -> f Runner) -> DotConfig -> f DotConfig)
-> ((LogFunc -> f LogFunc) -> Runner -> f Runner)
-> (LogFunc -> f LogFunc)
-> DotConfig
-> f DotConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(LogFunc -> f LogFunc) -> Runner -> f Runner
forall env. HasLogFunc env => Lens' env LogFunc
logFuncL
instance HasPantryConfig DotConfig where
pantryConfigL :: (PantryConfig -> f PantryConfig) -> DotConfig -> f DotConfig
pantryConfigL = (Config -> f Config) -> DotConfig -> f DotConfig
forall env. HasConfig env => Lens' env Config
configL((Config -> f Config) -> DotConfig -> f DotConfig)
-> ((PantryConfig -> f PantryConfig) -> Config -> f Config)
-> (PantryConfig -> f PantryConfig)
-> DotConfig
-> f DotConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(PantryConfig -> f PantryConfig) -> Config -> f Config
forall env. HasPantryConfig env => Lens' env PantryConfig
pantryConfigL
instance HasTerm DotConfig where
useColorL :: (Bool -> f Bool) -> DotConfig -> f DotConfig
useColorL = (Runner -> f Runner) -> DotConfig -> f DotConfig
forall env. HasRunner env => Lens' env Runner
runnerL((Runner -> f Runner) -> DotConfig -> f DotConfig)
-> ((Bool -> f Bool) -> Runner -> f Runner)
-> (Bool -> f Bool)
-> DotConfig
-> f DotConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Bool -> f Bool) -> Runner -> f Runner
forall env. HasTerm env => Lens' env Bool
useColorL
termWidthL :: (Int -> f Int) -> DotConfig -> f DotConfig
termWidthL = (Runner -> f Runner) -> DotConfig -> f DotConfig
forall env. HasRunner env => Lens' env Runner
runnerL((Runner -> f Runner) -> DotConfig -> f DotConfig)
-> ((Int -> f Int) -> Runner -> f Runner)
-> (Int -> f Int)
-> DotConfig
-> f DotConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Int -> f Int) -> Runner -> f Runner
forall env. HasTerm env => Lens' env Int
termWidthL
instance HasStylesUpdate DotConfig where
stylesUpdateL :: (StylesUpdate -> f StylesUpdate) -> DotConfig -> f DotConfig
stylesUpdateL = (Runner -> f Runner) -> DotConfig -> f DotConfig
forall env. HasRunner env => Lens' env Runner
runnerL((Runner -> f Runner) -> DotConfig -> f DotConfig)
-> ((StylesUpdate -> f StylesUpdate) -> Runner -> f Runner)
-> (StylesUpdate -> f StylesUpdate)
-> DotConfig
-> f DotConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(StylesUpdate -> f StylesUpdate) -> Runner -> f Runner
forall env. HasStylesUpdate env => Lens' env StylesUpdate
stylesUpdateL
instance HasGHCVariant DotConfig
instance HasPlatform DotConfig
instance HasRunner DotConfig where
runnerL :: (Runner -> f Runner) -> DotConfig -> f DotConfig
runnerL = (Config -> f Config) -> DotConfig -> f DotConfig
forall env. HasConfig env => Lens' env Config
configL((Config -> f Config) -> DotConfig -> f DotConfig)
-> ((Runner -> f Runner) -> Config -> f Config)
-> (Runner -> f Runner)
-> DotConfig
-> f DotConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Runner -> f Runner) -> Config -> f Config
forall env. HasRunner env => Lens' env Runner
runnerL
instance HasProcessContext DotConfig where
processContextL :: (ProcessContext -> f ProcessContext) -> DotConfig -> f DotConfig
processContextL = (Runner -> f Runner) -> DotConfig -> f DotConfig
forall env. HasRunner env => Lens' env Runner
runnerL((Runner -> f Runner) -> DotConfig -> f DotConfig)
-> ((ProcessContext -> f ProcessContext) -> Runner -> f Runner)
-> (ProcessContext -> f ProcessContext)
-> DotConfig
-> f DotConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(ProcessContext -> f ProcessContext) -> Runner -> f Runner
forall env. HasProcessContext env => Lens' env ProcessContext
processContextL
instance HasConfig DotConfig
instance HasBuildConfig DotConfig where
buildConfigL :: (BuildConfig -> f BuildConfig) -> DotConfig -> f DotConfig
buildConfigL = (DotConfig -> BuildConfig)
-> (DotConfig -> BuildConfig -> DotConfig)
-> Lens' DotConfig BuildConfig
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens DotConfig -> BuildConfig
dcBuildConfig (\DotConfig
x BuildConfig
y -> DotConfig
x { dcBuildConfig :: BuildConfig
dcBuildConfig = BuildConfig
y })
instance HasSourceMap DotConfig where
sourceMapL :: (SourceMap -> f SourceMap) -> DotConfig -> f DotConfig
sourceMapL = (DotConfig -> SourceMap)
-> (DotConfig -> SourceMap -> DotConfig)
-> Lens' DotConfig SourceMap
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens DotConfig -> SourceMap
dcSourceMap (\DotConfig
x SourceMap
y -> DotConfig
x { dcSourceMap :: SourceMap
dcSourceMap = SourceMap
y })