Add support for displaying when promotions are added in the graph rendering of a search trace.

5 files changed, 61 insertions, 7 deletions

diff --git a/tools/resolver-visualize/DotRender.hs b/tools/resolver-visualize/DotRender.hs
index 42124bed..ce33c4b4 100644
--- a/tools/resolver-visualize/DotRender.hs
+++ b/tools/resolver-visualize/DotRender.hs
@@ -74,7 +74,23 @@ dotUnprocessedSuccs params step = unprocessed ++ excluded
                           | (Successor { successorStep = step }) <- stepSuccessors step,
                             not $ inBounds params (stepOrder step) ]
 
-dotEdges params step = processed ++ unprocessed
+dotPromotions params step =
+    if not $ showPromotions params
+    then []
+    else [ node (name $ printf "step%dpromotion%d" (stepOrder step) promotionNum)
+           <<< set "label" (makeLabel promotion)
+           <<< set "shape" "oval"
+           | (promotion, promotionNum) <- zip (Set.toList $ stepPromotions step) ([0..] :: [Integer]) ]
+    where makeLabel p = if Set.size (promotionChoices p) <= 5
+                        then printf "%s\n%s"
+                                 (show $ promotionTier p)
+                                 (concat $ intersperse "\n"
+                                             [pp c | c <- Set.toList $ promotionChoices p])
+                        else printf "(T%s: %d choices)"
+                                 (show $ promotionTier p)
+                                 (Set.size $ promotionChoices p)
+
+dotEdges params step = processed ++ unprocessed ++ promotions
     where processed   = [ edge (node (name $ printf "step%d" (stepOrder step)))
                                (node (name $ printf "step%d" (stepOrder step')))
                           <<< set "label" (dotChoiceLabel succChoice)
@@ -92,6 +108,11 @@ dotEdges params step = processed ++ unprocessed
                           | ((Unprocessed { successorChoice = succChoice,
                                             successorForced = forced  }), stepNum)
                               <- zip (stepSuccessors step) ([0..] :: [Integer]) ]
+          promotions  = if (not $ showPromotions params) || (Set.null $ stepPromotions step)
+                        then []
+                        else [ edge (node (name $ printf "step%d" (stepOrder step)))
+                                    (node (name $ printf "step%dpromotion%d" (stepOrder step) promotionNum))
+                               | promotionNum <- [0..((Set.size $ stepPromotions step) - 1)] ]
 
 dotOrderEdges steps =
     [ edge (node (name $ printf "step%d" (stepOrder step1)))
@@ -109,9 +130,10 @@ renderDot params steps =
     then error "No steps to render."
     else let stepNodes          = map (dotStepNode params) truncatedSteps
              unprocessed        = concat $ map (dotUnprocessedSuccs params) truncatedSteps
+             promotions         = concat $ map (dotPromotions params) truncatedSteps
              stepEdges          = concat $ map (dotEdges params) truncatedSteps
              orderEdges         = dotOrderEdges truncatedSteps in
-         digraph (stepNodes ++ unprocessed) (stepEdges ++ orderEdges)
+         digraph (stepNodes ++ unprocessed ++ promotions) (stepEdges ++ orderEdges)
 
 writeDotRun params steps outputFile =
     do let dot = renderDot params steps
diff --git a/tools/resolver-visualize/Main.hs b/tools/resolver-visualize/Main.hs
index 25e3736b..ab82181c 100755
--- a/tools/resolver-visualize/Main.hs
+++ b/tools/resolver-visualize/Main.hs
@@ -1089,6 +1089,8 @@ filterUserParams ("--max-steps":(n:args)) params = let params' = params { maxSte
                                                    filterUserParams args params'
 filterUserParams ("--first-step":(n:args)) params = let params' = params { firstStep = Just $ read n } in
                                                     filterUserParams args params'
+filterUserParams ("--show-promotions":args) params = let params' = params { showPromotions = True } in
+                                                     filterUserParams args params'
 filterUserParams ("--dot-output":(fn:args)) params = let params' = params { dotOutput = Just $ fn } in
                                                      filterUserParams args params'
 filterUserParams ("--target-format":(fmt:args)) params =
@@ -1161,6 +1163,7 @@ data ParamsDialog = ParamsDialog { paramsDialog :: Dialog,
                                    paramsHboxSkipSteps :: HBox,
                                    paramsSkipStepsNumberEntry :: MaybeNumberEntry,
                                    paramsLabelSkipStepsMaxSteps :: Label,
+                                   paramsCheckboxShowPromotions :: CheckButton,
                                    paramsOkButton :: Button,
                                    paramsCancelButton :: Button }
 
@@ -1188,6 +1191,8 @@ makeParamsDialog params steps callback =
        sbSkip <- xmlGetWidget xml castToSpinButton "spinbutton_skip_steps"
        labelSkip <- xmlGetWidget xml castToLabel "label_skip_max_steps"
 
+       cbShowPromotions <- xmlGetWidget xml castToCheckButton "checkbutton_show_promotions"
+
        ok <- xmlGetWidget xml castToButton "params_ok"
        cancel <- xmlGetWidget xml castToButton "params_cancel"
 
@@ -1199,6 +1204,7 @@ makeParamsDialog params steps callback =
        skipEntry <- makeMaybeNumberEntry cbSkip sbSkip (firstStep params) (0, numSteps)
        labelSetText labelTruncateRun (stepLimitLabelText initialTruncateLimit)
        labelSetText labelSkip (skipStepsLabelText $ numSteps)
+       toggleButtonSetActive cbShowPromotions (showPromotions params)
 
        -- When the number of skipped steps is changed, we have to
        -- update the range and text of the max-steps box.
@@ -1207,7 +1213,9 @@ makeParamsDialog params steps callback =
                                     labelSetText labelTruncateRun (stepLimitLabelText truncateLimit)
                                     spinButtonSetRange sbTruncateRun 0 (fromIntegral truncateLimit))
 
-       afterResponse dialog (handleResponse dialog truncateRunEntry skipEntry)
+       -- TODO: should pass in the ParamsDialog if we add any more
+       -- widgets, rather than just tacking on parameters.
+       afterResponse dialog (handleResponse dialog truncateRunEntry skipEntry cbShowPromotions)
 
        widgetShow dialog
 
@@ -1218,17 +1226,20 @@ makeParamsDialog params steps callback =
                                paramsHboxSkipSteps = hboxSkip,
                                paramsSkipStepsNumberEntry = skipEntry,
                                paramsLabelSkipStepsMaxSteps = labelSkip,
+                               paramsCheckboxShowPromotions = cbShowPromotions,
                                paramsOkButton = ok,
                                paramsCancelButton = cancel }
-  where handleResponse dialog truncateRunEntry skipEntry ResponseOk =
+  where handleResponse dialog truncateRunEntry skipEntry showPromotionsButton ResponseOk =
             do maxSteps <- getMaybeNumberEntry truncateRunEntry
                firstStep <- getMaybeNumberEntry skipEntry
+               showPromotions <- toggleButtonGetActive showPromotionsButton
                let params' = params { maxSteps = maxSteps,
-                                      firstStep = firstStep }
+                                      firstStep = firstStep,
+                                      showPromotions = showPromotions }
                callback params'
                widgetDestroy dialog
                return ()
-        handleResponse dialog _ _ _ =
+        handleResponse dialog _ _ _ _ =
             do widgetDestroy dialog
                return ()
 
diff --git a/tools/resolver-visualize/Resolver/PrettyPrint.hs b/tools/resolver-visualize/Resolver/PrettyPrint.hs
index 8752bfa0..303e3396 100644
--- a/tools/resolver-visualize/Resolver/PrettyPrint.hs
+++ b/tools/resolver-visualize/Resolver/PrettyPrint.hs
@@ -2,6 +2,7 @@ module Resolver.PrettyPrint where
 
 import Data.ByteString.Char8(unpack)
 import Data.List
+import qualified Data.Set as Set
 import Resolver.Types
 
 class PP a where
@@ -23,4 +24,9 @@ instance PP Choice where
     ppS (InstallVersion ver _ _) = ("Install "++) . ppS ver
     ppS (BreakSoftDep d) = ("Break "++) . ppS d
 
+instance PP Promotion where
+    ppS (Promotion choices tier) = ('(':) . shows tier . (": ("++) .
+                                   (foldl' (.) id $ intersperse (", "++) $ map ppS $ Set.toList choices) .
+                                   (')':)
+
 pp x = ppS x ""
diff --git a/tools/resolver-visualize/Types.hs b/tools/resolver-visualize/Types.hs
index 0af31343..bff7ef61 100644
--- a/tools/resolver-visualize/Types.hs
+++ b/tools/resolver-visualize/Types.hs
@@ -11,6 +11,8 @@ data Params =
       maxSteps :: Maybe Integer,
       -- | The first step to start rendering.
       firstStep :: Maybe Integer,
+      -- | Whether to display promotions as nodes.
+      showPromotions :: Bool,
       -- | Where and whether to send dot output.
       dotOutput :: Maybe String,
       -- | The target output format.
@@ -18,5 +20,6 @@ data Params =
     } deriving(Eq, Ord, Show)
 defaultParams = Params { maxSteps  = Nothing,
                          firstStep = Nothing,
+                         showPromotions = False,
                          dotOutput = Nothing,
                          targetFormat = Nothing }
diff --git a/tools/resolver-visualize/resolver-visualize.glade b/tools/resolver-visualize/resolver-visualize.glade
index 6b0a2c13..05020b13 100644
--- a/tools/resolver-visualize/resolver-visualize.glade
+++ b/tools/resolver-visualize/resolver-visualize.glade
@@ -1,6 +1,6 @@
 <?xml version="1.0" encoding="UTF-8" standalone="no"?>
 <!DOCTYPE glade-interface SYSTEM "glade-2.0.dtd">
-<!--Generated with glade3 3.4.5 on Sat Apr  4 07:23:36 2009 -->
+<!--Generated with glade3 3.4.5 on Sun Apr  5 08:22:58 2009 -->
 <glade-interface>
   <widget class="GtkWindow" id="main_window">
     <property name="title" translatable="yes">Aptitude dependency resolution visualizer</property>
@@ -416,6 +416,18 @@
                 <property name="position">1</property>
               </packing>
             </child>
+            <child>
+              <widget class="GtkCheckButton" id="checkbutton_show_promotions">
+                <property name="visible">True</property>
+                <property name="can_focus">True</property>
+                <property name="label" translatable="yes">Show promotions</property>
+                <property name="response_id">0</property>
+                <property name="draw_indicator">True</property>
+              </widget>
+              <packing>
+                <property name="position">2</property>
+              </packing>
+            </child>
           </widget>
           <packing>
             <property name="expand">False</property>