[WIP] Add --json solver config arg

yvan-sraka · yvan-sraka · commit a56434897749 · 2023-10-23T11:53:29.000+02:00
This allows the cabal-install solver logs to be mechanized, e.g., similar to
the tree view provided by nix-output-monitor for Nix.
diff --git a/cabal-install-solver/src/Distribution/Solver/Modular.hs b/cabal-install-solver/src/Distribution/Solver/Modular.hs
@@ -54,7 +54,7 @@ import Distribution.Simple.Setup
 import Distribution.Simple.Utils
          ( ordNubBy )
 import Distribution.Verbosity
-
+import Distribution.Solver.Modular.Message (SolverTrace (..))
 
 -- | Ties the two worlds together: classic cabal-install vs. the modular
 -- solver. Performs the necessary translations before and after.
@@ -120,25 +120,25 @@ solve' :: SolverConfig
        -> (PN -> PackagePreferences)
        -> Map PN [LabeledPackageConstraint]
        -> Set PN
-       -> Progress String String (Assignment, RevDepMap)
+       -> Progress SolverTrace String (Assignment, RevDepMap)
 solve' sc cinfo idx pkgConfigDB pprefs gcs pns =
-    toProgress $ retry (runSolver printFullLog sc) createErrorMsg
+    toProgress $ retry (runSolver printFullLog sc) handleFailure
   where
     runSolver :: Bool -> SolverConfig
-              -> RetryLog String SolverFailure (Assignment, RevDepMap)
+              -> RetryLog SolverTrace SolverFailure (Assignment, RevDepMap)
     runSolver keepLog sc' =
         displayLogMessages keepLog $
         solve sc' cinfo idx pkgConfigDB pprefs gcs pns
 
-    createErrorMsg :: SolverFailure
-                   -> RetryLog String String (Assignment, RevDepMap)
-    createErrorMsg failure@(ExhaustiveSearch cs cm) =
+    handleFailure :: SolverFailure
+                   -> RetryLog SolverTrace String (Assignment, RevDepMap)
+    handleFailure failure@(ExhaustiveSearch cs _cm) =
       if asBool $ minimizeConflictSet sc
-      then continueWith ("Found no solution after exhaustively searching the "
+      then continueWith (mkErrorMsg ("Found no solution after exhaustively searching the "
                           ++ "dependency tree. Rerunning the dependency solver "
                           ++ "to minimize the conflict set ({"
-                          ++ showConflictSet cs ++ "}).") $
-           retry (tryToMinimizeConflictSet (runSolver printFullLog) sc cs cm) $
+                          ++ showConflictSet cs ++ "}).")) $
+           retry (tryToMinimizeConflictSet (runSolver printFullLog) sc cs _cm) $
                \case
                   ExhaustiveSearch cs' cm' ->
                       fromProgress $ Fail $
@@ -151,13 +151,13 @@ solve' sc cinfo idx pkgConfigDB pprefs gcs pns =
                        ++ "Original error message:\n"
                        ++ rerunSolverForErrorMsg cs
                        ++ finalErrorMsg sc failure
-      else fromProgress $ Fail $
-           rerunSolverForErrorMsg cs ++ finalErrorMsg sc failure
-    createErrorMsg failure@BackjumpLimitReached     =
+      else
+        fromProgress $ Fail $ rerunSolverForErrorMsg cs ++ finalErrorMsg sc failure
+    handleFailure failure@BackjumpLimitReached     =
         continueWith
-             ("Backjump limit reached. Rerunning dependency solver to generate "
+             (mkErrorMsg ("Backjump limit reached. Rerunning dependency solver to generate "
               ++ "a final conflict set for the search tree containing the "
-              ++ "first backjump.") $
+              ++ "first backjump.")) $
         retry (runSolver printFullLog sc { pruneAfterFirstSuccess = PruneAfterFirstSuccess True }) $
             \case
                ExhaustiveSearch cs _ ->
@@ -181,13 +181,16 @@ solve' sc cinfo idx pkgConfigDB pprefs gcs pns =
           -- original goal order.
           goalOrder' = preferGoalsFromConflictSet cs <> fromMaybe mempty (goalOrder sc)
 
-      in unlines ("Could not resolve dependencies:" : messages (toProgress (runSolver True sc')))
+      in unlines ("Could not resolve dependencies:" : map show (messages (toProgress (runSolver True sc'))))
 
     printFullLog = solverVerbosity sc >= verbose
 
     messages :: Progress step fail done -> [step]
     messages = foldProgress (:) (const []) (const [])
 
+mkErrorMsg :: String -> SolverTrace
+mkErrorMsg msg = ErrorMsg msg
+
 -- | Try to remove variables from the given conflict set to create a minimal
 -- conflict set.
 --
@@ -219,13 +222,13 @@ solve' sc cinfo idx pkgConfigDB pprefs gcs pns =
 --    solver to add new unnecessary variables to the conflict set. This function
 --    discards the result from any run that adds new variables to the conflict
 --    set, but the end result may not be completely minimized.
-tryToMinimizeConflictSet :: forall a . (SolverConfig -> RetryLog String SolverFailure a)
+tryToMinimizeConflictSet :: forall a . (SolverConfig -> RetryLog SolverTrace SolverFailure a)
                          -> SolverConfig
                          -> ConflictSet
                          -> ConflictMap
-                         -> RetryLog String SolverFailure a
+                         -> RetryLog SolverTrace SolverFailure a
 tryToMinimizeConflictSet runSolver sc cs cm =
-    foldl (\r v -> retryNoSolution r $ tryToRemoveOneVar v)
+    foldl (\r v -> retryMap mkErrorMsg $ retryNoSolution (retryMap show r) $ tryToRemoveOneVar v)
           (fromProgress $ Fail $ ExhaustiveSearch cs cm)
           (CS.toList cs)
   where
@@ -258,7 +261,7 @@ tryToMinimizeConflictSet runSolver sc cs cm =
       | otherwise =
         continueWith ("Trying to remove variable " ++ varStr ++ " from the "
                       ++ "conflict set.") $
-        retry (runSolver sc') $ \case
+        retry (retryMap show $ runSolver sc') $ \case
             err@(ExhaustiveSearch cs' _)
               | CS.toSet cs' `isSubsetOf` CS.toSet smallestKnownCS ->
                   let msg = if not $ CS.member v cs'
@@ -297,6 +300,9 @@ tryToMinimizeConflictSet runSolver sc cs cm =
         ExhaustiveSearch cs' cm' -> f cs' cm'
         BackjumpLimitReached     -> fromProgress (Fail BackjumpLimitReached)
 
+    retryMap :: (t -> step) -> RetryLog t fail done -> RetryLog step fail done
+    retryMap f l = fromProgress $ (\p -> foldProgress (\x xs -> Step (f x) xs) Fail Done p) $ toProgress l
+
 -- | Goal ordering that chooses goals contained in the conflict set before
 -- other goals.
 preferGoalsFromConflictSet :: ConflictSet
diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Log.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Log.hs
@@ -22,10 +22,10 @@ data SolverFailure =
 -- 'keepLog'), for efficiency.
 displayLogMessages :: Bool
                    -> RetryLog Message SolverFailure a
-                   -> RetryLog String SolverFailure a
+                   -> RetryLog SolverTrace SolverFailure a
 displayLogMessages keepLog lg = fromProgress $
     if keepLog
-    then showMessages progress
+    then groupMessages progress
     else foldProgress (const id) Fail Done progress
   where
     progress = toProgress lg
diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Message.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Message.hs
@@ -2,7 +2,8 @@
 
 module Distribution.Solver.Modular.Message (
     Message(..),
-    showMessages
+    SolverTrace(..),
+    groupMessages,
   ) where
 
 import qualified Data.List as L
@@ -41,51 +42,130 @@ data Message =
   | Success
   | Failure ConflictSet FailReason
 
+data Log
+  = PackageGoal QPN QGoalReason
+  | RejectF QFN Bool ConflictSet FailReason
+  | RejectS QSN Bool ConflictSet FailReason
+  | Skipping' (Set CS.Conflict)
+  | TryingF QFN Bool
+  | TryingP QPN POption (Maybe (GoalReason QPN))
+  | TryingS QSN Bool
+  | RejectMany QPN [POption] ConflictSet FailReason
+  | SkipMany QPN [POption] (Set CS.Conflict)
+  | UnknownPackage' QPN (GoalReason QPN)
+  | SuccessMsg
+  | FailureMsg ConflictSet FailReason
+
+data AtLevel a = AtLevel Int a
+
+type Trace = AtLevel Log
+
+data SolverTrace = SolverTrace Trace | ErrorMsg String
+
+instance Show SolverTrace where
+    show (SolverTrace i) = displayMessageAtLevel i
+    show (ErrorMsg s) = show s
+
+instance Show Log where
+    show = displayMessage
+
+displayMessageAtLevel :: Trace -> String
+displayMessageAtLevel (AtLevel l msg) =
+  let s = show l
+  in  "[" ++ replicate (3 - length s) '_' ++ s ++ "] " ++ displayMessage msg
+
+displayMessage :: Log -> String
+displayMessage (PackageGoal qpn gr) = "next goal: " ++ showQPN qpn ++ showGR gr
+displayMessage (RejectF qfn b c fr) = "rejecting: " ++ showQFNBool qfn b ++ showFR c fr
+displayMessage (RejectS qsn b c fr) = "rejecting: " ++ showQSNBool qsn b ++ showFR c fr
+displayMessage (Skipping' cs) = showConflicts cs
+displayMessage (TryingF qfn b) = "trying: " ++ showQFNBool qfn b
+displayMessage (TryingP qpn i mgr) = "trying: " ++ showQPNPOpt qpn i ++ maybe "" showGR mgr
+displayMessage (TryingS qsn b) = "trying: " ++ showQSNBool qsn b
+displayMessage (UnknownPackage' qpn gr) = "unknown package" ++ showQPN qpn ++ showGR gr
+displayMessage SuccessMsg = "done"
+displayMessage (FailureMsg c fr) = "fail: " ++ showFR c fr
+displayMessage (SkipMany _ _ cs) = "skipping: " ++ showConflicts cs
+-- TODO: Instead of displaying `aeson-1.0.2.1, aeson-1.0.2.0, aeson-1.0.1.0, ...`,
+-- the following line aim to display `aeson: 1.0.2.1, 1.0.2.0, 1.0.1.0, ...`.
+--
+-- displayMessage (RejectMany qpn is c fr) = "rejecting: " ++ fmtPkgsGroupedByName (map (showQPNPOpt qpn) (reverse is)) ++ showFR c fr
+displayMessage (RejectMany qpn is c fr) = "rejecting: " ++ L.intercalate ", " (map (showQPNPOpt qpn) (reverse is)) ++ showFR c fr
+
+-- TODO: This function should take as input the Index? So even without calling the solver, We can say things as
+-- "There is no version in the Hackage index that match the given constraints".
+--
+-- Alternatively, by passing this to the solver, we could get a more semantic output like:
+-- `all versions of aeson available are in conflict with ...`. Isn't already what `tryToMinimizeConflictSet` is doing?
+-- fmtPkgsGroupedByName :: [String] -> String
+-- fmtPkgsGroupedByName pkgs = L.intercalate " " $ fmtPkgGroup (groupByName pkgs)
+--   where
+--     groupByName :: [String] -> Map.Map String [String]
+--     groupByName = foldr f Map.empty
+--       where
+--         f versionString m = let (pkg, ver) = splitOnLastHyphen versionString
+--                             in Map.insertWith (++) pkg [ver] m
+--         -- FIXME: This is not a very robust way to split the package name and version.
+--         -- I should rather retrieve the package name and version from the QPN ...
+--         splitOnLastHyphen :: String -> (String, String)
+--         splitOnLastHyphen s =
+--             case reverse (L.elemIndices '-' s) of
+--                 (x:_)  -> (take x s, drop (x + 1) s)
+--                 _ -> error "splitOnLastHyphen: no hyphen found"
+
+--     fmtPkgGroup :: Map.Map String [String] -> [String]
+--     fmtPkgGroup = map formatEntry . Map.toList
+--       where
+--         formatEntry (pkg, versions) = pkg ++ ": " ++ L.intercalate ", " versions
+
 -- | Transforms the structured message type to actual messages (strings).
 --
 -- The log contains level numbers, which are useful for any trace that involves
 -- backtracking, because only the level numbers will allow to keep track of
 -- backjumps.
-showMessages :: Progress Message a b -> Progress String a b
-showMessages = go 0
+groupMessages :: Progress Message a b -> Progress SolverTrace a b
+groupMessages = go 0
   where
     -- 'go' increments the level for a recursive call when it encounters
     -- 'TryP', 'TryF', or 'TryS' and decrements the level when it encounters 'Leave'.
-    go :: Int -> Progress Message a b -> Progress String a b
+    go :: Int -> Progress Message a b -> Progress SolverTrace a b
     go !_ (Done x)                           = Done x
     go !_ (Fail x)                           = Fail x
+
     -- complex patterns
     go !l (Step (TryP qpn i) (Step Enter (Step (Failure c fr) (Step Leave ms)))) =
         goPReject l qpn [i] c fr ms
+
     go !l (Step (TryP qpn i) (Step Enter (Step (Skip conflicts) (Step Leave ms)))) =
         goPSkip l qpn [i] conflicts ms
+
     go !l (Step (TryF qfn b) (Step Enter (Step (Failure c fr) (Step Leave ms)))) =
-        (atLevel l $ "rejecting: " ++ showQFNBool qfn b ++ showFR c fr) (go l ms)
+        Step (SolverTrace $ AtLevel l $ (RejectF qfn b c fr)) (go l ms)
+
     go !l (Step (TryS qsn b) (Step Enter (Step (Failure c fr) (Step Leave ms)))) =
-        (atLevel l $ "rejecting: " ++ showQSNBool qsn b ++ showFR c fr) (go l ms)
+        Step (SolverTrace $ AtLevel l $ (RejectS qsn b c fr)) (go l ms)
+
+    -- "Trying ..." message when a new goal is started
     go !l (Step (Next (Goal (P _  ) gr)) (Step (TryP qpn' i) ms@(Step Enter (Step (Next _) _)))) =
-        (atLevel l $ "trying: " ++ showQPNPOpt qpn' i ++ showGR gr) (go l ms)
+        Step (SolverTrace $ AtLevel l $ (TryingP qpn' i (Just gr))) (go l ms)
+
     go !l (Step (Next (Goal (P qpn) gr)) (Step (Failure _c UnknownPackage) ms)) =
-        atLevel l ("unknown package: " ++ showQPN qpn ++ showGR gr) $ go l ms
+        Step (SolverTrace $ AtLevel l $ (UnknownPackage' qpn gr)) (go l ms)
+
     -- standard display
     go !l (Step Enter                    ms) = go (l+1) ms
     go !l (Step Leave                    ms) = go (l-1) ms
-    go !l (Step (TryP qpn i)             ms) = (atLevel l $ "trying: " ++ showQPNPOpt qpn i) (go l ms)
-    go !l (Step (TryF qfn b)             ms) = (atLevel l $ "trying: " ++ showQFNBool qfn b) (go l ms)
-    go !l (Step (TryS qsn b)             ms) = (atLevel l $ "trying: " ++ showQSNBool qsn b) (go l ms)
-    go !l (Step (Next (Goal (P qpn) gr)) ms) = (atLevel l $ showPackageGoal qpn gr) (go l ms)
-    go !l (Step (Next _)                 ms) = go l     ms -- ignore flag goals in the log
-    go !l (Step (Skip conflicts)         ms) =
-        -- 'Skip' should always be handled by 'goPSkip' in the case above.
-        (atLevel l $ "skipping: " ++ showConflicts conflicts) (go l ms)
-    go !l (Step (Success)                ms) = (atLevel l $ "done") (go l ms)
-    go !l (Step (Failure c fr)           ms) = (atLevel l $ showFailure c fr) (go l ms)
-
-    showPackageGoal :: QPN -> QGoalReason -> String
-    showPackageGoal qpn gr = "next goal: " ++ showQPN qpn ++ showGR gr
-
-    showFailure :: ConflictSet -> FailReason -> String
-    showFailure c fr = "fail" ++ showFR c fr
+
+    go !l (Step (TryP qpn i)             ms) = Step (SolverTrace $ AtLevel l $ (TryingP qpn i Nothing)) (go l ms)
+    go !l (Step (TryF qfn b)             ms) = Step (SolverTrace $ AtLevel l $ (TryingF qfn b)) (go l ms)
+    go !l (Step (TryS qsn b)             ms) = Step (SolverTrace $ AtLevel l $ (TryingS qsn b)) (go l ms)
+    go !l (Step (Next (Goal (P qpn) gr)) ms) = Step (SolverTrace $ AtLevel l $ (PackageGoal qpn gr)) (go l ms)
+    go !l (Step (Next _)                 ms) = go l ms -- ignore flag goals in the log
+
+    -- 'Skip' should always be handled by 'goPSkip' in the case above.
+    go !l (Step (Skip conflicts)         ms) = Step (SolverTrace $ AtLevel l $ (Skipping' conflicts)) (go l ms)
+    go !l (Step (Success)                ms) = Step (SolverTrace $ AtLevel l $ SuccessMsg) (go l ms)
+    go !l (Step (Failure c fr)           ms) = Step (SolverTrace $ AtLevel l $ (FailureMsg c fr)) (go l ms)
 
     -- special handler for many subsequent package rejections
     goPReject :: Int
@@ -94,32 +174,24 @@ showMessages = go 0
               -> ConflictSet
               -> FailReason
               -> Progress Message a b
-              -> Progress String a b
+              -> Progress SolverTrace a b
     goPReject l qpn is c fr (Step (TryP qpn' i) (Step Enter (Step (Failure _ fr') (Step Leave ms))))
-      | qpn == qpn' && fr == fr' = goPReject l qpn (i : is) c fr ms
+      | qpn == qpn' && fr == fr' =
+        goPReject l qpn (i : is) c fr ms
     goPReject l qpn is c fr ms =
-        (atLevel l $ "rejecting: " ++ L.intercalate ", " (map (showQPNPOpt qpn) (reverse is)) ++ showFR c fr) (go l ms)
+        Step (SolverTrace $ AtLevel l $ (RejectMany qpn is c fr)) (go l ms)
 
     -- Handle many subsequent skipped package instances.
     goPSkip :: Int
             -> QPN
             -> [POption]
             -> Set CS.Conflict
             -> Progress Message a b
-            -> Progress String a b
+            -> Progress SolverTrace a b
     goPSkip l qpn is conflicts (Step (TryP qpn' i) (Step Enter (Step (Skip conflicts') (Step Leave ms))))
       | qpn == qpn' && conflicts == conflicts' = goPSkip l qpn (i : is) conflicts ms
     goPSkip l qpn is conflicts ms =
-      let msg = "skipping: "
-                 ++ L.intercalate ", " (map (showQPNPOpt qpn) (reverse is))
-                 ++ showConflicts conflicts
-      in atLevel l msg (go l ms)
-
-    -- write a message with the current level number
-    atLevel :: Int -> String -> Progress String a b -> Progress String a b
-    atLevel l x xs =
-      let s = show l
-      in  Step ("[" ++ replicate (3 - length s) '_' ++ s ++ "] " ++ x) xs
+       Step (SolverTrace $ AtLevel l $ (SkipMany qpn is conflicts)) (go l ms)
 
 -- | Display the set of 'Conflicts' for a skipped package version.
 showConflicts :: Set CS.Conflict -> String
diff --git a/cabal-install-solver/src/Distribution/Solver/Types/DependencyResolver.hs b/cabal-install-solver/src/Distribution/Solver/Types/DependencyResolver.hs
@@ -17,6 +17,7 @@ import Distribution.Simple.PackageIndex ( InstalledPackageIndex )
 import Distribution.Package ( PackageName )
 import Distribution.Compiler ( CompilerInfo )
 import Distribution.System ( Platform )
+import Distribution.Solver.Modular.Message ( SolverTrace )
 
 -- | A dependency resolver is a function that works out an installation plan
 -- given the set of installed and available packages and a set of deps to
@@ -34,4 +35,4 @@ type DependencyResolver loc = Platform
                            -> (PackageName -> PackagePreferences)
                            -> [LabeledPackageConstraint]
                            -> Set PackageName
-                           -> Progress String String [ResolverPackage loc]
+                           -> Progress SolverTrace String [ResolverPackage loc]
diff --git a/cabal-install/src/Distribution/Client/Dependency.hs b/cabal-install/src/Distribution/Client/Dependency.hs
