Skip to content

Commit

Permalink
WIP ...
Browse files Browse the repository at this point in the history
  • Loading branch information
yvan-sraka committed Dec 22, 2023
1 parent f8a74e5 commit 68a4d80
Show file tree
Hide file tree
Showing 5 changed files with 75 additions and 27 deletions.
4 changes: 2 additions & 2 deletions cabal-install-solver/src/Distribution/Solver/Modular.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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(..) )
Expand Down Expand Up @@ -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.
Expand Down
34 changes: 17 additions & 17 deletions cabal-install-solver/src/Distribution/Solver/Modular/Message.hs
Original file line number Diff line number Diff line change
Expand Up @@ -48,7 +48,7 @@ import Distribution.Solver.Types.PackagePath
import Distribution.Solver.Types.Progress
( Progress(..),
SummarizedMessage(..),
EntryMsg(..),
EntryMessage(..),
Entry(..),
Message(..) )
import Distribution.Types.LibraryName
Expand All @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand All @@ -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
Expand Down
11 changes: 8 additions & 3 deletions cabal-install-solver/src/Distribution/Solver/Types/Progress.hs
Original file line number Diff line number Diff line change
@@ -1,9 +1,11 @@
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE DerivingStrategies #-}
module Distribution.Solver.Types.Progress
( Progress(..)
, foldProgress
, Message(..)
, Entry(..)
, EntryMsg(..)
, EntryMessage(..)
, SummarizedMessage(..)
) where

Expand Down Expand Up @@ -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)
48 changes: 43 additions & 5 deletions cabal-install/src/Distribution/Client/Dependency.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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)
)
Expand Down Expand Up @@ -227,6 +231,8 @@ import Distribution.Version
, transformCaretUpper
, withinRange
)
import Distribution.Client.Utils.Json
( encodeToString, ToJSON(..), (.=), object, Value(String) )

-- ------------------------------------------------------------

Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
5 changes: 5 additions & 0 deletions foobar/CHANGELOG.md
Original file line number Diff line number Diff line change
@@ -0,0 +1,5 @@
# Revision history for foobar

## 0.1.0.0 -- YYYY-mm-dd

* First version. Released on an unsuspecting world.

0 comments on commit 68a4d80

Please sign in to comment.