module Stack.Dot (dot
,listDependencies
,DotOpts(..)
,DotPayload(..)
,ListDepsOpts(..)
,resolveDependencies
,printGraph
,pruneGraph
) where
import Control.Applicative
import Control.Arrow ((&&&))
import Control.Monad (liftM, void)
import Control.Monad.IO.Class
import Control.Monad.Trans.Unlift (MonadBaseUnlift)
import qualified Data.Foldable as F
import qualified Data.HashSet as HashSet
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe
import Data.Monoid ((<>))
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.IO as Text
import qualified Data.Traversable as T
import Distribution.License (License)
import Prelude
import Stack.Build (withLoadPackage)
import Stack.Build.Installed (getInstalled, GetInstalledOpts(..))
import Stack.Build.Source
import Stack.Build.Target
import Stack.Constants
import Stack.Package
import Stack.Types.Build
import Stack.Types.Config
import Stack.Types.FlagName
import Stack.Types.Package
import Stack.Types.PackageName
import Stack.Types.StackT
import Stack.Types.Version
data DotOpts = DotOpts
{ dotIncludeExternal :: !Bool
, dotIncludeBase :: !Bool
, dotDependencyDepth :: !(Maybe Int)
, dotPrune :: !(Set String)
, dotTargets :: [Text]
, dotFlags :: !(Map (Maybe PackageName) (Map FlagName Bool))
, dotTestTargets :: Bool
, dotBenchTargets :: Bool
}
data ListDepsOpts = ListDepsOpts
{ listDepsDotOpts :: !DotOpts
, listDepsSep :: !Text
, listDepsLicense :: !Bool
}
dot :: (StackM env m, HasEnvConfig env, MonadBaseUnlift IO m)
=> DotOpts
-> m ()
dot dotOpts = do
(localNames, prunedGraph) <- createPrunedDependencyGraph dotOpts
printGraph dotOpts localNames prunedGraph
data DotPayload = DotPayload
{ payloadVersion :: Maybe Version
, payloadLicense :: Maybe License
} deriving (Eq, Show)
createPrunedDependencyGraph :: (StackM env m, HasEnvConfig env, MonadBaseUnlift IO m)
=> DotOpts
-> m (Set PackageName,
Map PackageName (Set PackageName, DotPayload))
createPrunedDependencyGraph dotOpts = do
localNames <- liftM Map.keysSet getLocalPackageViews
resultGraph <- createDependencyGraph dotOpts
let pkgsToPrune = if dotIncludeBase dotOpts
then dotPrune dotOpts
else Set.insert "base" (dotPrune dotOpts)
prunedGraph = pruneGraph localNames pkgsToPrune resultGraph
return (localNames, prunedGraph)
createDependencyGraph :: (StackM env m, HasEnvConfig env, MonadBaseUnlift IO m)
=> DotOpts
-> m (Map PackageName (Set PackageName, DotPayload))
createDependencyGraph dotOpts = do
(locals,sourceMap) <- loadSourceMap NeedTargets defaultBuildOptsCLI
{ boptsCLITargets = dotTargets dotOpts
, boptsCLIFlags = dotFlags dotOpts
}
let graph = Map.fromList (localDependencies dotOpts (filter lpWanted locals))
menv <- getMinimalEnvOverride
installedMap <- fmap snd . fst4 <$> getInstalled menv
(GetInstalledOpts False False)
sourceMap
withLoadPackage menv (\loader -> do
let depLoader =
createDepLoader sourceMap
installedMap
(fmap4 (packageAllDeps &&& makePayload) loader)
liftIO $ resolveDependencies (dotDependencyDepth dotOpts) graph depLoader)
where
fmap4 :: Functor f => (r -> r') -> (a -> b -> c -> d -> f r) -> a -> b -> c -> d -> f r'
fmap4 f g a b c d = f <$> g a b c d
fst4 :: (a,b,c,d) -> a
fst4 (x,_,_,_) = x
makePayload pkg = DotPayload (Just $ packageVersion pkg) (Just $ packageLicense pkg)
listDependencies :: (StackM env m, HasEnvConfig env, MonadBaseUnlift IO m)
=> ListDepsOpts
-> m ()
listDependencies opts = do
let dotOpts = listDepsDotOpts opts
(_, resultGraph) <- createPrunedDependencyGraph dotOpts
void (Map.traverseWithKey go (snd <$> resultGraph))
where go name payload =
let payloadText =
if listDepsLicense opts
then maybe "<unknown>" (Text.pack . show) (payloadLicense payload)
else maybe "<unknown>" (Text.pack . show) (payloadVersion payload)
line = packageNameText name <> listDepsSep opts <> payloadText
in liftIO $ Text.putStrLn line
pruneGraph :: (F.Foldable f, F.Foldable g, Eq a)
=> f PackageName
-> g String
-> Map PackageName (Set PackageName, a)
-> Map PackageName (Set PackageName, a)
pruneGraph dontPrune names =
pruneUnreachable dontPrune . Map.mapMaybeWithKey (\pkg (pkgDeps,x) ->
if show pkg `F.elem` names
then Nothing
else let filtered = Set.filter (\n -> show 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 :: Applicative m
=> Map PackageName PackageSource
-> Map PackageName Installed
-> (PackageName -> Version -> Map FlagName Bool -> [Text] -> m (Set PackageName, DotPayload))
-> PackageName
-> m (Set PackageName, DotPayload)
createDepLoader sourceMap installed loadPackageDeps pkgName =
case Map.lookup pkgName sourceMap of
Just (PSLocal lp) -> pure (packageAllDeps pkg, payloadFromLocal pkg)
where
pkg = localPackageToPackage lp
Just (PSUpstream version _ flags ghcOptions _) -> loadPackageDeps pkgName version flags ghcOptions
Nothing -> pure (Set.empty, payloadFromInstalled (Map.lookup pkgName installed))
where
payloadFromLocal pkg = DotPayload (Just $ packageVersion pkg) (Just $ packageLicense pkg)
payloadFromInstalled maybePkg = DotPayload (fmap installedVersion maybePkg) Nothing
localDependencies :: DotOpts -> [LocalPackage] -> [(PackageName, (Set PackageName, DotPayload))]
localDependencies dotOpts locals =
map (\lp -> let pkg = localPackageToPackage lp
in (packageName pkg, (deps pkg, lpPayload pkg)))
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 = DotPayload (Just $ packageVersion pkg) (Just $ packageLicense pkg)
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 ->
packageNameString 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 = "\"" <> packageNameText 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 = (`HashSet.member` wiredInPackages)
localPackageToPackage :: LocalPackage -> Package
localPackageToPackage lp =
fromMaybe (lpPackage lp) (lpTestBench lp)