From 68a4d804c13663c4cdebe8f81f3f72c6351f2437 Mon Sep 17 00:00:00 2001 From: Yvan Sraka Date: Fri, 22 Dec 2023 15:40:32 +0100 Subject: [PATCH] WIP ... --- .../src/Distribution/Solver/Modular.hs | 4 +- .../Distribution/Solver/Modular/Message.hs | 34 ++++++------- .../src/Distribution/Solver/Types/Progress.hs | 11 +++-- .../src/Distribution/Client/Dependency.hs | 48 +++++++++++++++++-- foobar/CHANGELOG.md | 5 ++ 5 files changed, 75 insertions(+), 27 deletions(-) create mode 100644 foobar/CHANGELOG.md diff --git a/cabal-install-solver/src/Distribution/Solver/Modular.hs b/cabal-install-solver/src/Distribution/Solver/Modular.hs index 2837d683386..43d510bd1f2 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular.hs +++ b/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. diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Message.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Message.hs index def4b0915c1..855bbbb2647 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Message.hs +++ b/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 diff --git a/cabal-install-solver/src/Distribution/Solver/Types/Progress.hs b/cabal-install-solver/src/Distribution/Solver/Types/Progress.hs index 3cfe82e258f..a4c9ffe3260 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/Progress.hs +++ b/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) \ No newline at end of file diff --git a/cabal-install/src/Distribution/Client/Dependency.hs b/cabal-install/src/Distribution/Client/Dependency.hs index 91cc1f1010a..7d91eaa6122 100644 --- a/cabal-install/src/Distribution/Client/Dependency.hs +++ b/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 @@ -177,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) ) @@ -227,6 +231,8 @@ import Distribution.Version , transformCaretUpper , withinRange ) +import Distribution.Client.Utils.Json + ( encodeToString, ToJSON(..), (.=), object, Value(String) ) -- ------------------------------------------------------------ @@ -314,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 @@ -904,7 +912,7 @@ resolveDependencies platform comp pkgConfigDB params = formatProgress :: Progress SummarizedMessage String a -> Progress String String a formatProgress p = foldProgress (\x xs -> Step (formatter x) xs) Fail Done p where - formatter = if outputJson then error "FIXME: To be implemented ..." else renderSummarizedMessage + formatter = if outputJson then encodeToString else renderSummarizedMessage preferences :: PackageName -> PackagePreferences preferences = interpretPackagesPreference targets defpref prefs @@ -1299,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 \ No newline at end of file diff --git a/foobar/CHANGELOG.md b/foobar/CHANGELOG.md new file mode 100644 index 00000000000..ef8fc188528 --- /dev/null +++ b/foobar/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for foobar + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world.