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