Skip to content

Commit 68a4d80

Browse files
yvan-srakayvan-sraka
committed
WIP ...
1 parent f8a74e5 commit 68a4d80

File tree

5 files changed

+75
-27
lines changed

5 files changed

+75
-27
lines changed

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

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -62,7 +62,7 @@ import Distribution.Solver.Types.PackagePreferences
6262
import Distribution.Solver.Types.PkgConfigDb
6363
( PkgConfigDb )
6464
import Distribution.Solver.Types.Progress
65-
( Progress(..), foldProgress, SummarizedMessage(ErrorMsg) )
65+
( Progress(..), foldProgress, SummarizedMessage(ErrorMessage) )
6666
import Distribution.Solver.Types.Variable ( Variable(..) )
6767
import Distribution.System
6868
( Platform(..) )
@@ -206,7 +206,7 @@ solve' sc cinfo idx pkgConfigDB pprefs gcs pns =
206206
messages = foldProgress (:) (const []) (const [])
207207

208208
mkErrorMsg :: String -> SummarizedMessage
209-
mkErrorMsg msg = ErrorMsg msg
209+
mkErrorMsg msg = ErrorMessage msg
210210

211211
-- | Try to remove variables from the given conflict set to create a minimal
212212
-- conflict set.

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

Lines changed: 17 additions & 17 deletions
Original file line numberDiff line numberDiff line change
@@ -48,7 +48,7 @@ import Distribution.Solver.Types.PackagePath
4848
import Distribution.Solver.Types.Progress
4949
( Progress(..),
5050
SummarizedMessage(..),
51-
EntryMsg(..),
51+
EntryMessage(..),
5252
Entry(..),
5353
Message(..) )
5454
import Distribution.Types.LibraryName
@@ -57,10 +57,10 @@ import Distribution.Types.UnqualComponentName
5757
( unUnqualComponentName )
5858

5959
renderSummarizedMessage :: SummarizedMessage -> String
60-
renderSummarizedMessage (SummarizedMsg i) = displayMessageAtLevel i
61-
renderSummarizedMessage (ErrorMsg s) = s
60+
renderSummarizedMessage (SummarizedMessage i) = displayMessageAtLevel i
61+
renderSummarizedMessage (ErrorMessage s) = s
6262

63-
displayMessageAtLevel :: EntryMsg -> String
63+
displayMessageAtLevel :: EntryMessage -> String
6464
displayMessageAtLevel (AtLevel l msg) =
6565
let s = show l
6666
in "[" ++ replicate (3 - length s) '_' ++ s ++ "] " ++ displayMessage msg
@@ -101,32 +101,32 @@ summarizeMessages = go 0
101101
goPSkip l qpn [i] conflicts ms
102102

103103
go !l (Step (TryF qfn b) (Step Enter (Step (Failure c fr) (Step Leave ms)))) =
104-
Step (SummarizedMsg $ AtLevel l $ (LogRejectF qfn b c fr)) (go l ms)
104+
Step (SummarizedMessage $ AtLevel l $ (LogRejectF qfn b c fr)) (go l ms)
105105

106106
go !l (Step (TryS qsn b) (Step Enter (Step (Failure c fr) (Step Leave ms)))) =
107-
Step (SummarizedMsg $ AtLevel l $ (LogRejectS qsn b c fr)) (go l ms)
107+
Step (SummarizedMessage $ AtLevel l $ (LogRejectS qsn b c fr)) (go l ms)
108108

109109
-- "Trying ..." message when a new goal is started
110110
go !l (Step (Next (Goal (P _ ) gr)) (Step (TryP qpn' i) ms@(Step Enter (Step (Next _) _)))) =
111-
Step (SummarizedMsg $ AtLevel l $ (LogTryingP qpn' i (Just gr))) (go l ms)
111+
Step (SummarizedMessage $ AtLevel l $ (LogTryingP qpn' i (Just gr))) (go l ms)
112112

113113
go !l (Step (Next (Goal (P qpn) gr)) (Step (Failure _c UnknownPackage) ms)) =
114-
Step (SummarizedMsg $ AtLevel l $ (LogUnknownPackage qpn gr)) (go l ms)
114+
Step (SummarizedMessage $ AtLevel l $ (LogUnknownPackage qpn gr)) (go l ms)
115115

116116
-- standard display
117117
go !l (Step Enter ms) = go (l+1) ms
118118
go !l (Step Leave ms) = go (l-1) ms
119119

120-
go !l (Step (TryP qpn i) ms) = Step (SummarizedMsg $ AtLevel l $ (LogTryingP qpn i Nothing)) (go l ms)
121-
go !l (Step (TryF qfn b) ms) = Step (SummarizedMsg $ AtLevel l $ (LogTryingF qfn b)) (go l ms)
122-
go !l (Step (TryS qsn b) ms) = Step (SummarizedMsg $ AtLevel l $ (LogTryingS qsn b)) (go l ms)
123-
go !l (Step (Next (Goal (P qpn) gr)) ms) = Step (SummarizedMsg $ AtLevel l $ (LogPackageGoal qpn gr)) (go l ms)
120+
go !l (Step (TryP qpn i) ms) = Step (SummarizedMessage $ AtLevel l $ (LogTryingP qpn i Nothing)) (go l ms)
121+
go !l (Step (TryF qfn b) ms) = Step (SummarizedMessage $ AtLevel l $ (LogTryingF qfn b)) (go l ms)
122+
go !l (Step (TryS qsn b) ms) = Step (SummarizedMessage $ AtLevel l $ (LogTryingS qsn b)) (go l ms)
123+
go !l (Step (Next (Goal (P qpn) gr)) ms) = Step (SummarizedMessage $ AtLevel l $ (LogPackageGoal qpn gr)) (go l ms)
124124
go !l (Step (Next _) ms) = go l ms -- ignore flag goals in the log
125125

126126
-- 'Skip' should always be handled by 'goPSkip' in the case above.
127-
go !l (Step (Skip conflicts) ms) = Step (SummarizedMsg $ AtLevel l $ (LogSkipping conflicts)) (go l ms)
128-
go !l (Step (Success) ms) = Step (SummarizedMsg $ AtLevel l $ LogSuccessMsg) (go l ms)
129-
go !l (Step (Failure c fr) ms) = Step (SummarizedMsg $ AtLevel l $ (LogFailureMsg c fr)) (go l ms)
127+
go !l (Step (Skip conflicts) ms) = Step (SummarizedMessage $ AtLevel l $ (LogSkipping conflicts)) (go l ms)
128+
go !l (Step (Success) ms) = Step (SummarizedMessage $ AtLevel l $ LogSuccessMsg) (go l ms)
129+
go !l (Step (Failure c fr) ms) = Step (SummarizedMessage $ AtLevel l $ (LogFailureMsg c fr)) (go l ms)
130130

131131
-- special handler for many subsequent package rejections
132132
goPReject :: Int
@@ -140,7 +140,7 @@ summarizeMessages = go 0
140140
| qpn == qpn' && fr == fr' =
141141
goPReject l qpn (i : is) c fr ms
142142
goPReject l qpn is c fr ms =
143-
Step (SummarizedMsg $ AtLevel l $ (LogRejectMany qpn is c fr)) (go l ms)
143+
Step (SummarizedMessage $ AtLevel l $ (LogRejectMany qpn is c fr)) (go l ms)
144144

145145
-- Handle many subsequent skipped package instances.
146146
goPSkip :: Int
@@ -152,7 +152,7 @@ summarizeMessages = go 0
152152
goPSkip l qpn is conflicts (Step (TryP qpn' i) (Step Enter (Step (Skip conflicts') (Step Leave ms))))
153153
| qpn == qpn' && conflicts == conflicts' = goPSkip l qpn (i : is) conflicts ms
154154
goPSkip l qpn is conflicts ms =
155-
Step (SummarizedMsg $ AtLevel l $ (LogSkipMany qpn is conflicts)) (go l ms)
155+
Step (SummarizedMessage $ AtLevel l $ (LogSkipMany qpn is conflicts)) (go l ms)
156156

157157
-- | Display the set of 'Conflicts' for a skipped package version.
158158
showConflicts :: Set CS.Conflict -> String

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

Lines changed: 8 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -1,9 +1,11 @@
1+
{-# LANGUAGE InstanceSigs #-}
2+
{-# LANGUAGE DerivingStrategies #-}
13
module Distribution.Solver.Types.Progress
24
( Progress(..)
35
, foldProgress
46
, Message(..)
57
, Entry(..)
6-
, EntryMsg(..)
8+
, EntryMessage(..)
79
, SummarizedMessage(..)
810
) where
911

@@ -84,7 +86,10 @@ data Entry
8486
| LogUnknownPackage QPN (GoalReason QPN)
8587
| LogSuccessMsg
8688
| LogFailureMsg ConflictSet FailReason
89+
deriving stock (Show, Eq)
8790

88-
data EntryMsg = AtLevel Int Entry
91+
data EntryMessage = AtLevel Int Entry
92+
deriving stock (Show, Eq)
8993

90-
data SummarizedMessage = SummarizedMsg EntryMsg | ErrorMsg String
94+
data SummarizedMessage = SummarizedMessage EntryMessage | ErrorMessage String
95+
deriving stock (Show, Eq)

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

Lines changed: 43 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -14,6 +14,9 @@
1414
-- Portability : portable
1515
--
1616
-- Top level interface to dependency resolution.
17+
{-# LANGUAGE InstanceSigs #-}
18+
{-# OPTIONS_GHC -Wno-orphans #-}
19+
1720
module Distribution.Client.Dependency
1821
( -- * The main package dependency resolver
1922
DepResolverParams
@@ -177,10 +180,11 @@ import Distribution.Solver.Types.PackagePreferences
177180
)
178181
import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb)
179182
import Distribution.Solver.Types.Progress
180-
( Progress (..)
181-
, SummarizedMessage
182-
, foldProgress
183-
)
183+
( SummarizedMessage(..),
184+
Progress(..),
185+
foldProgress,
186+
Entry(..),
187+
EntryMessage(..) )
184188
import Distribution.Solver.Types.ResolverPackage
185189
( ResolverPackage (Configured)
186190
)
@@ -227,6 +231,8 @@ import Distribution.Version
227231
, transformCaretUpper
228232
, withinRange
229233
)
234+
import Distribution.Client.Utils.Json
235+
( encodeToString, ToJSON(..), (.=), object, Value(String) )
230236

231237
-- ------------------------------------------------------------
232238

@@ -314,6 +320,8 @@ showDepResolverParams p =
314320
showLabeledConstraint (LabeledPackageConstraint pc src) =
315321
showPackageConstraint pc ++ " (" ++ showConstraintSource src ++ ")"
316322

323+
324+
317325
-- | A package selection preference for a particular package.
318326
--
319327
-- Preferences are soft constraints that the dependency resolver should try to
@@ -904,7 +912,7 @@ resolveDependencies platform comp pkgConfigDB params =
904912
formatProgress :: Progress SummarizedMessage String a -> Progress String String a
905913
formatProgress p = foldProgress (\x xs -> Step (formatter x) xs) Fail Done p
906914
where
907-
formatter = if outputJson then error "FIXME: To be implemented ..." else renderSummarizedMessage
915+
formatter = if outputJson then encodeToString else renderSummarizedMessage
908916

909917
preferences :: PackageName -> PackagePreferences
910918
preferences = interpretPackagesPreference targets defpref prefs
@@ -1299,3 +1307,33 @@ instance Show ResolveNoDepsError where
12991307
++ prettyShow name
13001308
++ " that satisfies "
13011309
++ prettyShow (simplifyVersionRange ver)
1310+
1311+
-------------------------------------------------------------------------------
1312+
-- Orphans
1313+
-------------------------------------------------------------------------------
1314+
1315+
instance ToJSON SummarizedMessage where
1316+
toJSON :: SummarizedMessage -> Value
1317+
toJSON (SummarizedMessage x) = object ["status" .= String "success", "message" .= toJSON x]
1318+
toJSON (ErrorMessage x) = object ["status" .= String "failure", "message" .= String x]
1319+
1320+
instance ToJSON EntryMessage where
1321+
toJSON :: EntryMessage -> Value
1322+
toJSON (AtLevel _ x) = toJSON x
1323+
1324+
instance ToJSON Entry where
1325+
toJSON :: Entry -> Value
1326+
toJSON (LogPackageGoal _ _) = error "To be implemented..."
1327+
toJSON (LogRejectF _ _ _ _) = error "To be implemented..."
1328+
toJSON (LogRejectS _ _ _ _) = error "TODO"
1329+
toJSON (LogSkipping _) = error "To be implemented..."
1330+
toJSON (LogTryingF _ _) = error "To be implemented..."
1331+
toJSON (LogTryingP _ _ _) = error "To be implemented..."
1332+
toJSON (LogTryingS _ _) = error "To be implemented..."
1333+
toJSON (LogRejectMany _ _ _ _) = error "To be implemented..."
1334+
toJSON (LogSkipMany _ _ _) = error "To be implemented..."
1335+
toJSON (LogUnknownPackage _ _) = error "To be implemented..."
1336+
toJSON (LogSuccessMsg) = error "To be implemented..."
1337+
toJSON (LogFailureMsg _ _) = error "To be implemented..."
1338+
1339+
-- TODO: write a test that assert that: toJSON fromJson == fromJSON toJson == id

‎foobar/CHANGELOG.md

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,5 @@
1+
# Revision history for foobar
2+
3+
## 0.1.0.0 -- YYYY-mm-dd
4+
5+
* First version. Released on an unsuspecting world.

0 commit comments

Comments
 (0)