Add support for parsing and rendering backpropagations.

Currently this is turned on whenever promotions are being shown.  It's
not 100% clear to me that it actually works.

2 files changed, 125 insertions, 11 deletions

diff --git a/tools/resolver-visualize/DotRender.hs b/tools/resolver-visualize/DotRender.hs
index ce33c4b4..bbc443ed 100644
--- a/tools/resolver-visualize/DotRender.hs
+++ b/tools/resolver-visualize/DotRender.hs
@@ -81,6 +81,11 @@ dotPromotions params step =
            <<< set "label" (makeLabel promotion)
            <<< set "shape" "oval"
            | (promotion, promotionNum) <- zip (Set.toList $ stepPromotions step) ([0..] :: [Integer]) ]
+         ++
+         [ node (name $ printf "step%dbackprop%d" (stepOrder step) backpropNum)
+           <<< set "label" (makeLabel $ backpropagationPromotion backprop)
+           <<< set "shape" "oval" 
+           | (backprop, backpropNum) <- zip (stepBackpropagations step) ([0..] :: [Integer]) ]
     where makeLabel p = if Set.size (promotionChoices p) <= 5
                         then printf "%s\n%s"
                                  (show $ promotionTier p)
@@ -90,7 +95,7 @@ dotPromotions params step =
                                  (show $ promotionTier p)
                                  (Set.size $ promotionChoices p)
 
-dotEdges params step = processed ++ unprocessed ++ promotions
+dotEdges params step = cutIncoming ++ processed ++ unprocessed ++ promotions ++ backprops
     where processed   = [ edge (node (name $ printf "step%d" (stepOrder step)))
                                (node (name $ printf "step%d" (stepOrder step')))
                           <<< set "label" (dotChoiceLabel succChoice)
@@ -104,7 +109,7 @@ dotEdges params step = processed ++ unprocessed ++ promotions
           unprocessed = [ edge (node (name $ printf "step%d" (stepOrder step)))
                                (node (name $ printf "step%dunproc%d" (stepOrder step) stepNum))
                           <<< set "label" (dotChoiceLabel succChoice)
-                          <<< forced `thenDo` set "style" "bold"
+                          <<< forced `thenDo` set "color" "black:black"
                           | ((Unprocessed { successorChoice = succChoice,
                                             successorForced = forced  }), stepNum)
                               <- zip (stepSuccessors step) ([0..] :: [Integer]) ]
@@ -113,6 +118,33 @@ dotEdges params step = processed ++ unprocessed ++ promotions
                         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)] ]
+                             ++
+                             -- Structural edges to backpropagations.
+                             [ edge (node (name $ printf "step%d" (stepOrder $ backpropagationStep backprop)))
+                                    (node (name $ printf "step%dbackprop%d" (stepOrder step) backpropNum))
+                               | (backprop, backpropNum) <- zip (stepBackpropagations step) ([0..] :: [Integer]) ]
+          backprops   = let attrs = set "color" "red" `andAlso`
+                                    set "style" "dashed" `andAlso`
+                                    set "constraint" "false" in
+                        if (not $ showPromotions params) || (null $ stepBackpropagations step)
+                        then []
+                        -- Temporal edges to backpropagations.
+                        else [edge (node (name $ printf "step%d" (stepOrder step)))
+                                   (node (name $ printf "step%dbackprop0" (stepOrder step)))
+                              <<< attrs]
+                             ++
+                             [edge (node (name $ printf "step%dbackprop%d" (stepOrder step) backpropNum))
+                                   (node (name $ printf "step%dbackprop%d" (stepOrder step) (backpropNum + 1)))
+                              <<< attrs
+                              | backpropNum <- [0..((length $ stepBackpropagations step) - 2)] ]
+          cutIncoming = [ edge (node (name $ printf "step%d" (stepOrder parentStep)))
+                               (node (name $ printf "step%d" (stepOrder step)))
+                          <<< set "label" (dotChoiceLabel choice)
+                          <<< forced `thenDo` set "color" "black:black"
+                          | ParentLink { parentLinkAction = choice,
+                                         parentLinkForced = forced,
+                                         parentLinkParent = parentStep }
+                              <- maybeToList $ stepPredecessor step ]
 
 dotOrderEdges steps =
     [ edge (node (name $ printf "step%d" (stepOrder step1)))
diff --git a/tools/resolver-visualize/Resolver/Log.hs b/tools/resolver-visualize/Resolver/Log.hs
index 35ff47de..5a5d930f 100644
--- a/tools/resolver-visualize/Resolver/Log.hs
+++ b/tools/resolver-visualize/Resolver/Log.hs
@@ -5,6 +5,7 @@ module Resolver.Log(
                     ProcessingStep(..),
                     LinkChoice(..),
                     Successor(..),
+                    Backpropagation(..),
                     ParentLink(..),
                     loadLogFile
                    )
@@ -56,6 +57,7 @@ data LinkChoice = LinkChoice Choice
 
 -- | Represents the link from a parent solution to a child solution.
 data ParentLink = ParentLink { parentLinkAction :: LinkChoice,
+                               parentLinkForced :: Bool,
                                parentLinkParent :: ProcessingStep }
 
 -- | A successor link either goes to a processing step, or it says
@@ -67,6 +69,13 @@ data Successor = Successor { successorStep   :: ProcessingStep,
                                successorChoice   :: LinkChoice,
                                successorForced   :: Bool }
 
+-- | Represents backpropagating promotions up the search tree.
+--
+-- The solution identifies the target step; the promotion is the new
+-- promotion that was generated by this propagation.
+data Backpropagation = Backpropagation { backpropagationStep :: ProcessingStep,
+                                         backpropagationPromotion :: Promotion }
+
 data ProcessingStep = ProcessingStep { -- | How we got here; Nothing
                                        -- if this is the root node or
                                        -- if we didn't see an
@@ -82,8 +91,14 @@ data ProcessingStep = ProcessingStep { -- | How we got here; Nothing
                                        -- step.
                                        stepSuccessors :: [Successor],
                                        -- | Promotions generated at
-                                       -- this step.
+                                       -- this step.  Includes
+                                       -- promotions propagated
+                                       -- backwards from successor
+                                       -- steps.
                                        stepPromotions :: Set.Set Promotion,
+                                       -- | Backpropagations performed
+                                       -- | at this step.
+                                       stepBackpropagations :: [Backpropagation],
                                        -- | The first position in the
                                        -- log file of the log text for
                                        -- this step.
@@ -124,6 +139,8 @@ data PartialStep = PartialStep { -- | The search node generated by this step.
                                  -- | The successors of this
                                  -- step, in reverse order.
                                  pstepReverseSuccessors :: ![(Solution, LinkChoice, Bool)],
+                                 -- | Backpropagations at this step, in reverse order.
+                                 pstepReverseBackpropagations :: ![(Solution, Promotion)],
                                  -- | Promotions generated at
                                  -- this step.
                                  pstepPromotions :: ![Promotion],
@@ -145,6 +162,7 @@ newPartialStep sol startPos =
     PartialStep {
   pstepSol = sol,
   pstepReverseSuccessors = [],
+  pstepReverseBackpropagations = [],
   pstepPromotions = [],
   pstepTextStart = startPos,
   pstepTextLength = Nothing
@@ -168,6 +186,9 @@ tryingResolution    = compile "Trying to resolve (.*) by installing (.*)(from th
 tryingUnresolved    = compile "Trying to leave (.*) unresolved$"
 enqueuing           = compile "Enqueuing (.*)$"
 successorsEnd       = compile "Done generating successors\\."
+-- Start generating backpropagations.
+backpropagationsBegin = compile "Backpropagating solutions to step ([0-9]*): (.*)$"
+backpropagationAdd  = compile "Created backpropagated promotion at step ([0-9]*): (.*)$"
 
 -- | The log lines we know how to parse: the first regex that matches
 -- causes the corresponding function to be invoked on the match
@@ -181,7 +202,9 @@ lineParsers = [
  (tryingResolution, processTryingResolutionLine),
  (tryingUnresolved, processTryingUnresolvedLine),
  (madeSuccessor, processGeneratedLine),
- (successorsEnd, processSuccessorsEndLine) ]
+ (successorsEnd, processSuccessorsEndLine),
+ (backpropagationsBegin, processBackpropagationsBegin),
+ (backpropagationAdd, processBackpropagationAdd) ]
 
 data GeneratingSuccessorsInfo =
     GeneratingSuccessorsInfo { generatingForced :: !Bool,
@@ -221,7 +244,10 @@ data LogParseState = LogParseState {
       --
       -- Could be "trying to resolve (dep) by installing (ver)", or
       -- "trying to leave (dep) unresolved".
-      logParseLastSeenTryChoice :: !LinkChoice
+      logParseLastSeenTryChoice :: !LinkChoice,
+      -- | The solution, if any, that we are currently backpropagating
+      -- promotions to.
+      logParsePromotionBackpropagationState :: !(Maybe Solution)
     }
 
 initialState sourceName =
@@ -233,7 +259,8 @@ initialState sourceName =
                     logParseCurrentLineStart = 0,
                     logParseGeneratingSuccessorsInfo = Nothing,
                     logParseSeenPromotions = Nothing,
-                    logParseLastSeenTryChoice = Unknown }
+                    logParseLastSeenTryChoice = Unknown,
+                    logParsePromotionBackpropagationState = Nothing }
 
 -- | The log parsing state monad.
 type LogParse = ReaderT (IORef LogParseState) IO
@@ -381,6 +408,23 @@ modifyLastStep f =
                newFirstStep `seq`
                setAllStepsReversed $ (f $ head steps):(tail steps))
 
+getPromotionBackpropagationState :: LogParse (Maybe Solution)
+getPromotionBackpropagationState = get >>= return . logParsePromotionBackpropagationState
+
+setPromotionBackpropagationState :: Maybe Solution -> LogParse ()
+setPromotionBackpropagationState sol =
+    do st <- get
+       put $ st { logParsePromotionBackpropagationState = sol }
+
+addBackpropagatedPromotionToCurrentStep :: Solution -> Promotion -> LogParse ()
+addBackpropagatedPromotionToCurrentStep p sol =
+    p `seq` sol `seq`
+    modifyLastStep (\lastStep -> lastStep {
+                                   pstepReverseBackpropagations =
+                                       (p, sol):(pstepReverseBackpropagations lastStep)
+                                 })
+
+
 -- | Add a step at the end of the list of steps.
 --
 -- Strict in the new step.
@@ -421,6 +465,7 @@ startNewStep sol =
       -- Reset state variables.
       setGeneratingSuccessorsInfo Nothing
       setLastSeenTryChoice Unknown
+      setPromotionBackpropagationState Nothing
 
 -- | Add a successor to a partial step.
 --
@@ -480,6 +525,30 @@ processSuccessorsEndLine source matches =
     do setGeneratingSuccessorsInfo Nothing
        setLastSeenTryChoice Unknown
 
+-- | Process a line of the log file that starts backpropagations for
+-- the current step.
+--
+-- This currently just assumes that backpropagations happen only once
+-- per step.
+processBackpropagationsBegin :: ByteString -> MatchArray -> LogParse ()
+processBackpropagationsBegin source matches =
+    do sol <- parseMatch solution source (matches!2)
+       sol `seq` setPromotionBackpropagationState (Just sol)
+
+-- | Process a line of the log file that indicates that a new
+-- backpropagation was emitted.
+processBackpropagationAdd :: ByteString -> MatchArray -> LogParse ()
+processBackpropagationAdd source matches =
+    do maybeSol <- getPromotionBackpropagationState
+       (case maybeSol of
+          Nothing  -> return ()
+          Just sol ->
+              do p <- parseMatch promotion source (matches!2)
+                 seen <- promotionIsSeen p
+                 unless seen $ do
+                   addSeenPromotion p
+                   p `seq` sol `seq` addBackpropagatedPromotionToCurrentStep sol p)
+
 -- | Process a line of the log file that indicates that a particular
 -- resolution was attempted.
 --
@@ -574,11 +643,11 @@ forEachLine h f progress = do total <- liftIO $ hFileSize h
 
 -- Extract predecessor links in terms of solutions, in an arbitrary
 -- order.
-extractPredecessorLinks :: [PartialStep] -> [(Solution, (Solution, LinkChoice))]
+extractPredecessorLinks :: [PartialStep] -> [(Solution, (Solution, LinkChoice, Bool))]
 extractPredecessorLinks [] = []
 extractPredecessorLinks (step:steps) =
-    [(childSolution, (pstepSol step, childChoice))
-     | (childSolution, childChoice, _) <- pstepReverseSuccessors step]
+    [(childSolution, (pstepSol step, childChoice, forced))
+     | (childSolution, childChoice, forced) <- pstepReverseSuccessors step]
     ++ extractPredecessorLinks steps
 
 -- | Map a list of partial processing steps (in order) to a collection
@@ -602,8 +671,10 @@ extractProcessingSteps partialSteps =
       -- Another lazily generated map that gives the parent link (if
       -- any) of each solution.
       parentMap :: Map.Map Solution ParentLink
-      parentMap = Map.fromList [(child, ParentLink c (stepMap Map.! parent))
-                                | (child, (parent, c)) <- extractPredecessorLinks partialSteps]
+      parentMap = Map.fromList [(child, ParentLink { parentLinkAction = c,
+                                                     parentLinkForced = forced,
+                                                     parentLinkParent = (stepMap Map.! parent) })
+                                | (child, (parent, c, forced)) <- extractPredecessorLinks partialSteps]
       -- Builds a successor link for the given solution.
       findSuccessor :: Solution -> Solution -> LinkChoice -> Bool -> Successor
       findSuccessor oldSol sol c forced =
@@ -612,6 +683,14 @@ extractProcessingSteps partialSteps =
           else case Map.lookup sol stepMap of
                  Just step -> Successor step c forced
                  Nothing   -> Unprocessed sol c forced
+
+      findBackpropagation :: (Solution, Promotion) -> Backpropagation
+      findBackpropagation (sol, p) =
+          case Map.lookup sol stepMap of
+            Just step -> step `seq` p `seq` Backpropagation { backpropagationStep = step,
+                                                              backpropagationPromotion = p }
+            Nothing -> error $ "No match for the solution " ++ show sol ++ " when adding the backpropagated promotion " ++ show p
+
       -- How to build an output step from an input step.  This is
       -- where the knot gets tied, using stepMap.  It works because
       -- the key values in the map can be computed without having to
@@ -623,6 +702,8 @@ extractProcessingSteps partialSteps =
               psuccessors    = reverse $ pstepReverseSuccessors pstep
               successors     = [findSuccessor sol sol' c forced
                                     | (sol', c, forced) <- psuccessors]
+              pbackprops     = reverse $ pstepReverseBackpropagations pstep
+              backprops      = map findBackpropagation pbackprops
               promotions     = Set.fromList $ pstepPromotions pstep
               succDepth succ = case succ of
                                  Successor { successorStep = step } -> stepDepth step
@@ -643,6 +724,7 @@ extractProcessingSteps partialSteps =
         stepOrder = n,
         stepSuccessors = successors,
         stepPromotions = promotions,
+        stepBackpropagations = backprops,
         stepTextStart  = start,
         stepTextLength = len,
         stepDepth      = depth,