[WIP] Add --json solver config arg

This allows the cabal-install solver logs to be mechanized, e.g., similar to
the tree view provided by nix-output-monitor for Nix.

Author: yvan-sraka

cabal-install-solver/src/Distribution/Solver/Modular.hs

@@ -62,7 +62,7 @@ import Distribution.Solver.Types.PackagePreferences
 import Distribution.Solver.Types.PkgConfigDb
     ( PkgConfigDb )
 import Distribution.Solver.Types.Progress
-    ( Progress(..), foldProgress, SummarizedMessage(ErrorMsg) )
+    ( Progress(..), foldProgress, SummarizedMessage(ErrorMessage) )
 import Distribution.Solver.Types.Variable ( Variable(..) )
 import Distribution.System
     ( Platform(..) )
@@ -206,7 +206,7 @@ solve' sc cinfo idx pkgConfigDB pprefs gcs pns =
     messages = foldProgress (:) (const []) (const [])
 
 mkErrorMsg :: String -> SummarizedMessage
-mkErrorMsg msg = ErrorMsg msg
+mkErrorMsg msg = ErrorMessage msg
 
 -- | Try to remove variables from the given conflict set to create a minimal
 -- conflict set.

cabal-install-solver/src/Distribution/Solver/Modular/Message.hs

@@ -48,7 +48,7 @@ import Distribution.Solver.Types.PackagePath
 import Distribution.Solver.Types.Progress
     ( Progress(..),
       SummarizedMessage(..),
-      EntryMsg(..),
+      EntryMessage(..),
       Entry(..),
       Message(..) )
 import Distribution.Types.LibraryName
@@ -57,10 +57,10 @@ import Distribution.Types.UnqualComponentName
     ( unUnqualComponentName )
 
 renderSummarizedMessage :: SummarizedMessage -> String
-renderSummarizedMessage (SummarizedMsg i) = displayMessageAtLevel i
-renderSummarizedMessage (ErrorMsg s) = s
+renderSummarizedMessage (SummarizedMessage i) = displayMessageAtLevel i
+renderSummarizedMessage (ErrorMessage s) = s
 
-displayMessageAtLevel :: EntryMsg -> String
+displayMessageAtLevel :: EntryMessage -> String
 displayMessageAtLevel (AtLevel l msg) =
   let s = show l
   in  "[" ++ replicate (3 - length s) '_' ++ s ++ "] " ++ displayMessage msg
@@ -101,32 +101,32 @@ summarizeMessages = go 0
         goPSkip l qpn [i] conflicts ms
 
     go !l (Step (TryF qfn b) (Step Enter (Step (Failure c fr) (Step Leave ms)))) =
-        Step (SummarizedMsg $ AtLevel l $ (LogRejectF qfn b c fr)) (go l ms)
+        Step (SummarizedMessage $ AtLevel l $ (LogRejectF qfn b c fr)) (go l ms)
 
     go !l (Step (TryS qsn b) (Step Enter (Step (Failure c fr) (Step Leave ms)))) =
-        Step (SummarizedMsg $ AtLevel l $ (LogRejectS qsn b c fr)) (go l ms)
+        Step (SummarizedMessage $ AtLevel l $ (LogRejectS 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 _) _)))) =
-        Step (SummarizedMsg $ AtLevel l $ (LogTryingP qpn' i (Just gr))) (go l ms)
+        Step (SummarizedMessage $ AtLevel l $ (LogTryingP qpn' i (Just gr))) (go l ms)
 
     go !l (Step (Next (Goal (P qpn) gr)) (Step (Failure _c UnknownPackage) ms)) =
-        Step (SummarizedMsg $ AtLevel l $ (LogUnknownPackage qpn gr)) (go l ms)
+        Step (SummarizedMessage $ AtLevel l $ (LogUnknownPackage 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) = Step (SummarizedMsg $ AtLevel l $ (LogTryingP qpn i Nothing)) (go l ms)
-    go !l (Step (TryF qfn b)             ms) = Step (SummarizedMsg $ AtLevel l $ (LogTryingF qfn b)) (go l ms)
-    go !l (Step (TryS qsn b)             ms) = Step (SummarizedMsg $ AtLevel l $ (LogTryingS qsn b)) (go l ms)
-    go !l (Step (Next (Goal (P qpn) gr)) ms) = Step (SummarizedMsg $ AtLevel l $ (LogPackageGoal qpn gr)) (go l ms)
+    go !l (Step (TryP qpn i)             ms) = Step (SummarizedMessage $ AtLevel l $ (LogTryingP qpn i Nothing)) (go l ms)
+    go !l (Step (TryF qfn b)             ms) = Step (SummarizedMessage $ AtLevel l $ (LogTryingF qfn b)) (go l ms)
+    go !l (Step (TryS qsn b)             ms) = Step (SummarizedMessage $ AtLevel l $ (LogTryingS qsn b)) (go l ms)
+    go !l (Step (Next (Goal (P qpn) gr)) ms) = Step (SummarizedMessage $ AtLevel l $ (LogPackageGoal 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 (SummarizedMsg $ AtLevel l $ (LogSkipping conflicts)) (go l ms)
-    go !l (Step (Success)                ms) = Step (SummarizedMsg $ AtLevel l $ LogSuccessMsg) (go l ms)
-    go !l (Step (Failure c fr)           ms) = Step (SummarizedMsg $ AtLevel l $ (LogFailureMsg c fr)) (go l ms)
+    go !l (Step (Skip conflicts)         ms) = Step (SummarizedMessage $ AtLevel l $ (LogSkipping conflicts)) (go l ms)
+    go !l (Step (Success)                ms) = Step (SummarizedMessage $ AtLevel l $ LogSuccessMsg) (go l ms)
+    go !l (Step (Failure c fr)           ms) = Step (SummarizedMessage $ AtLevel l $ (LogFailureMsg c fr)) (go l ms)
 
     -- special handler for many subsequent package rejections
     goPReject :: Int
@@ -140,7 +140,7 @@ summarizeMessages = go 0
       | qpn == qpn' && fr == fr' =
         goPReject l qpn (i : is) c fr ms
     goPReject l qpn is c fr ms =
-        Step (SummarizedMsg $ AtLevel l $ (LogRejectMany qpn is c fr)) (go l ms)
+        Step (SummarizedMessage $ AtLevel l $ (LogRejectMany qpn is c fr)) (go l ms)
 
     -- Handle many subsequent skipped package instances.
     goPSkip :: Int
@@ -152,7 +152,7 @@ summarizeMessages = go 0
     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 =
-       Step (SummarizedMsg $ AtLevel l $ (LogSkipMany qpn is conflicts)) (go l ms)
+       Step (SummarizedMessage $ AtLevel l $ (LogSkipMany qpn is conflicts)) (go l ms)
 
 -- | Display the set of 'Conflicts' for a skipped package version.
 showConflicts :: Set CS.Conflict -> String

cabal-install-solver/src/Distribution/Solver/Types/Progress.hs

@@ -1,9 +1,11 @@
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE DerivingStrategies #-}
 module Distribution.Solver.Types.Progress
     ( Progress(..)
     , foldProgress
     , Message(..)
     , Entry(..)
-    , EntryMsg(..)
+    , EntryMessage(..)
     , SummarizedMessage(..)
     ) where
 
@@ -84,7 +86,10 @@ data Entry
   | LogUnknownPackage QPN (GoalReason QPN)
   | LogSuccessMsg
   | LogFailureMsg ConflictSet FailReason
+  deriving stock (Show, Eq)
 
-data EntryMsg = AtLevel Int Entry
+data EntryMessage = AtLevel Int Entry
+  deriving stock (Show, Eq)
 
-data SummarizedMessage = SummarizedMsg EntryMsg | ErrorMsg String
+data SummarizedMessage = SummarizedMessage EntryMessage | ErrorMessage String
+  deriving stock (Show, Eq)

cabal-install/src/Distribution/Client/Dependency.hs

@@ -14,6 +14,9 @@
 -- Portability :  portable
 --
 -- Top level interface to dependency resolution.
+{-# LANGUAGE InstanceSigs #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+
 module Distribution.Client.Dependency
   ( -- * The main package dependency resolver
     DepResolverParams
@@ -59,6 +62,7 @@ module Distribution.Client.Dependency
   , setSolveExecutables
   , setGoalOrder
   , setSolverVerbosity
+  , setSolverOutputJson
   , removeLowerBounds
   , removeUpperBounds
   , addDefaultSetupDependencies
@@ -176,10 +180,11 @@ import Distribution.Solver.Types.PackagePreferences
   )
 import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb)
 import Distribution.Solver.Types.Progress
-  ( Progress (..)
-  , SummarizedMessage
-  , foldProgress
-  )
+    ( SummarizedMessage(..),
+      Progress(..),
+      foldProgress,
+      Entry(..),
+      EntryMessage(..) )
 import Distribution.Solver.Types.ResolverPackage
   ( ResolverPackage (Configured)
   )
@@ -226,6 +231,8 @@ import Distribution.Version
   , transformCaretUpper
   , withinRange
   )
+import Distribution.Client.Utils.Json
+    ( encodeToString, ToJSON(..), (.=), object, Value(String) )
 
 -- ------------------------------------------------------------
 
@@ -266,6 +273,7 @@ data DepResolverParams = DepResolverParams
   , depResolverGoalOrder :: Maybe (Variable QPN -> Variable QPN -> Ordering)
   -- ^ Function to override the solver's goal-ordering heuristics.
   , depResolverVerbosity :: Verbosity
+  , depResolverOutputJson :: Bool
   }
 
 showDepResolverParams :: DepResolverParams -> String
@@ -312,6 +320,8 @@ showDepResolverParams p =
     showLabeledConstraint (LabeledPackageConstraint pc src) =
       showPackageConstraint pc ++ " (" ++ showConstraintSource src ++ ")"
 
+
+
 -- | A package selection preference for a particular package.
 --
 -- Preferences are soft constraints that the dependency resolver should try to
@@ -363,6 +373,7 @@ basicDepResolverParams installedPkgIndex sourcePkgIndex =
     , depResolverSolveExecutables = SolveExecutables True
     , depResolverGoalOrder = Nothing
     , depResolverVerbosity = normal
+    , depResolverOutputJson = False
     }
 
 addTargets
@@ -498,6 +509,12 @@ setSolverVerbosity verbosity params =
     { depResolverVerbosity = verbosity
     }
 
+setSolverOutputJson :: Bool -> DepResolverParams -> DepResolverParams
+setSolverOutputJson outputJson params =
+  params
+    { depResolverOutputJson = outputJson
+    }
+
 -- | Some packages are specific to a given compiler version and should never be
 -- reinstalled.
 dontInstallNonReinstallablePackages :: DepResolverParams -> DepResolverParams
@@ -886,13 +903,16 @@ resolveDependencies platform comp pkgConfigDB params =
                     solveExes
                     order
                     verbosity
+                    outputJson
                   ) =
         if asBool (depResolverAllowBootLibInstalls params)
           then params
           else dontInstallNonReinstallablePackages params
 
     formatProgress :: Progress SummarizedMessage String a -> Progress String String a
-    formatProgress p = foldProgress (\x xs -> Step (renderSummarizedMessage x) xs) Fail Done p
+    formatProgress p = foldProgress (\x xs -> Step (formatter x) xs) Fail Done p
+      where
+        formatter = if outputJson then encodeToString else renderSummarizedMessage
 
     preferences :: PackageName -> PackagePreferences
     preferences = interpretPackagesPreference targets defpref prefs
@@ -1210,6 +1230,7 @@ resolveWithoutDependencies
       _onlyConstrained
       _order
       _verbosity
+      _outputJson
     ) =
     collectEithers $ map selectPackage (Set.toList targets)
     where
@@ -1286,3 +1307,33 @@ instance Show ResolveNoDepsError where
       ++ prettyShow name
       ++ " that satisfies "
       ++ prettyShow (simplifyVersionRange ver)
+
+-------------------------------------------------------------------------------
+-- Orphans
+-------------------------------------------------------------------------------
+
+instance ToJSON SummarizedMessage where
+  toJSON :: SummarizedMessage -> Value
+  toJSON (SummarizedMessage x) = object ["status" .= String "success", "message" .= toJSON x]
+  toJSON (ErrorMessage x) = object ["status" .= String "failure", "message" .= String x]
+
+instance ToJSON EntryMessage where
+  toJSON :: EntryMessage -> Value
+  toJSON (AtLevel _ x) = toJSON x
+
+instance ToJSON Entry where
+  toJSON :: Entry -> Value
+  toJSON (LogPackageGoal _ _) = error "To be implemented..."
+  toJSON (LogRejectF _ _ _ _) = error "To be implemented..."
+  toJSON (LogRejectS _ _ _ _) = error "TODO"
+  toJSON (LogSkipping _) = error "To be implemented..."
+  toJSON (LogTryingF _ _) = error "To be implemented..."
+  toJSON (LogTryingP _ _ _) = error "To be implemented..."
+  toJSON (LogTryingS _ _) = error "To be implemented..."
+  toJSON (LogRejectMany _ _ _ _) = error "To be implemented..."
+  toJSON (LogSkipMany _ _ _) = error "To be implemented..."
+  toJSON (LogUnknownPackage _ _) = error "To be implemented..."
+  toJSON (LogSuccessMsg) = error "To be implemented..."
+  toJSON (LogFailureMsg _ _) = error "To be implemented..."
+
+  -- TODO: write a test that assert that: toJSON fromJson == fromJSON toJson == id