From 1833de64b800485de84a916331eb7265f7936b3b Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Fri, 23 Nov 2012 11:07:57 +0200
Subject: [PATCH] Basic dep tree display

---
 Stackage/Config.hs         |  9 +++++++++
 Stackage/InstallInfo.hs    | 20 +++++++++++++++++++-
 Stackage/NarrowDatabase.hs | 17 +++++++++--------
 3 files changed, 37 insertions(+), 9 deletions(-)

diff --git a/Stackage/Config.hs b/Stackage/Config.hs
index f5d18872..026e6591 100644
--- a/Stackage/Config.hs
+++ b/Stackage/Config.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 module Stackage.Config where
 
 import           Control.Monad              (unless, when)
@@ -63,3 +64,11 @@ stablePackages = execWriter $ do
         case simpleParse range of
             Nothing -> error $ "Invalid range " ++ show range ++ " for " ++ package
             Just range' -> tell $ Map.singleton (PackageName package) range'
+
+verbose :: Bool
+verbose =
+#if VERBOSE
+    True
+#else
+    False
+#endif
diff --git a/Stackage/InstallInfo.hs b/Stackage/InstallInfo.hs
index 3a5305dc..d5a4d29c 100644
--- a/Stackage/InstallInfo.hs
+++ b/Stackage/InstallInfo.hs
@@ -3,6 +3,7 @@ module Stackage.InstallInfo
     , iiPackageList
     ) where
 
+import Control.Monad (when)
 import qualified Data.Map                 as Map
 import qualified Data.Set                 as Set
 import           Stackage.Config
@@ -11,6 +12,7 @@ import           Stackage.LoadDatabase
 import           Stackage.NarrowDatabase
 import           Stackage.Types
 import           Stackage.Util
+import Data.Version (showVersion)
 
 getInstallInfo :: IO InstallInfo
 getInstallInfo = do
@@ -19,10 +21,26 @@ getInstallInfo = do
     let totalCore = extraCore `Set.union` Set.map (\(PackageIdentifier p _) -> p) (hpcore hp)
     pdb <- loadPackageDB totalCore allPackages
     final <- narrowPackageDB pdb $ Set.fromList $ Map.keys allPackages
+
+    when verbose $ do
+        putStrLn "Basic dependency listing:"
+        mapM_ (putStrLn . showDep) $ Map.toList final
     return InstallInfo
         { iiCore = totalCore
-        , iiPackages = final
+        , iiPackages = Map.map fst final
         }
 
+showDep :: (PackageName, (Version, [PackageName])) -> String
+showDep (name, (version, deps)) =
+    concat
+        [ unP name
+        , "-"
+        , showVersion version
+        , ": "
+        , unwords $ map unP deps
+        ]
+  where
+    unP (PackageName p) = p
+
 iiPackageList :: InstallInfo -> [String]
 iiPackageList = map packageVersionString . Map.toList . iiPackages
diff --git a/Stackage/NarrowDatabase.hs b/Stackage/NarrowDatabase.hs
index 66d929f0..7b92a2ad 100644
--- a/Stackage/NarrowDatabase.hs
+++ b/Stackage/NarrowDatabase.hs
@@ -9,22 +9,23 @@ import           Stackage.Types
 -- their dependencies.
 narrowPackageDB :: PackageDB
                 -> Set PackageName
-                -> IO (Map PackageName Version)
+                -> IO (Map PackageName (Version, [PackageName]))
 narrowPackageDB (PackageDB pdb) =
-    loop Map.empty . Set.map ((,) True)
+    loop Map.empty . Set.map ((,) [])
   where
     loop result toProcess =
         case Set.minView toProcess of
             Nothing -> return result
-            Just ((isOrig, p), toProcess') ->
+            Just ((users, p), toProcess') ->
                 case Map.lookup p pdb of
                     Nothing
-                        | isOrig -> error $ "Unknown package: " ++ show p
+                        | null users -> error $ "Unknown package: " ++ show p
                         | otherwise -> loop result toProcess'
                     Just pi -> do
-                        let result' = Map.insert p (piVersion pi) result
-                        loop result' $ Set.foldl' (addDep result') toProcess' $ piDeps pi
-    addDep result toProcess p =
+                        let users' = p:users
+                            result' = Map.insert p (piVersion pi, users) result
+                        loop result' $ Set.foldl' (addDep users' result') toProcess' $ piDeps pi
+    addDep users result toProcess p =
         case Map.lookup p result of
-            Nothing -> Set.insert (False, p) toProcess
+            Nothing -> Set.insert (users, p) toProcess
             Just{} -> toProcess