@@ -21,13 +21,12 @@ import Distribution.Package
21
21
import Distribution.Text (display )
22
22
import Distribution.Version (Version )
23
23
24
- import Control.Monad.Catch (MonadThrow , MonadCatch )
25
24
import Data.Aeson
26
25
import Data.ByteString.Lazy (ByteString )
27
26
import Data.Containers.ListUtils (nubOrd )
28
27
import Data.List (mapAccumL , sortOn )
29
28
import qualified Data.List.NonEmpty as NE
30
- import Data.Maybe (catMaybes , fromJust )
29
+ import Data.Maybe (catMaybes , mapMaybe , fromMaybe )
31
30
import Data.Function (fix )
32
31
import qualified Data.Bimap as Bimap
33
32
import qualified Data.Array as Arr
@@ -44,18 +43,18 @@ data ReverseFeature = ReverseFeature {
44
43
45
44
reverseHook :: Hook [NE. NonEmpty PkgInfo ] () ,
46
45
47
- queryReverseDeps :: forall m . ( MonadIO m , MonadCatch m ) => PackageName -> m ([PackageName ], [PackageName ]),
48
- revPackageId :: forall m . ( MonadCatch m , MonadIO m ) => PackageId -> m ReverseDisplay ,
49
- revPackageName :: forall m . ( MonadIO m , MonadCatch m ) => PackageName -> m ReverseDisplay ,
50
- renderReverseRecent :: forall m . ( MonadIO m , MonadCatch m ) => PackageName -> ReverseDisplay -> m ReversePageRender ,
51
- renderReverseOld :: forall m . ( MonadIO m , MonadCatch m ) => PackageName -> ReverseDisplay -> m ReversePageRender ,
52
- revPackageFlat :: forall m . ( MonadIO m , MonadCatch m ) => PackageName -> m [(PackageName , Int )],
53
- revDirectCount :: forall m . ( MonadIO m , MonadCatch m ) => PackageName -> m Int ,
54
- revPackageStats :: forall m . ( MonadIO m , MonadCatch m ) => PackageName -> m ReverseCount ,
55
- revCountForAllPackages :: forall m . ( MonadIO m , MonadCatch m ) => m [(PackageName , ReverseCount )],
56
- revJSON :: forall m . ( MonadIO m , MonadThrow m ) => m ByteString ,
46
+ queryReverseDeps :: forall m . MonadIO m => PackageName -> m ([PackageName ], [PackageName ]),
47
+ revPackageId :: forall m . MonadIO m => PackageId -> m ReverseDisplay ,
48
+ revPackageName :: forall m . MonadIO m => PackageName -> m ReverseDisplay ,
49
+ renderReverseRecent :: forall m . MonadIO m => PackageName -> ReverseDisplay -> m ReversePageRender ,
50
+ renderReverseOld :: forall m . MonadIO m => PackageName -> ReverseDisplay -> m ReversePageRender ,
51
+ revPackageFlat :: forall m . MonadIO m => PackageName -> m [(PackageName , Int )],
52
+ revDirectCount :: forall m . MonadIO m => PackageName -> m Int ,
53
+ revPackageStats :: forall m . MonadIO m => PackageName -> m ReverseCount ,
54
+ revCountForAllPackages :: forall m . MonadIO m => m [(PackageName , ReverseCount )],
55
+ revJSON :: IO ByteString ,
57
56
revDisplayInfo :: forall m . MonadIO m => m VersionIndex ,
58
- revForEachVersion :: forall m . ( MonadIO m , MonadThrow m ) => PackageName -> m (Map. Map Version (Set PackageIdentifier ))
57
+ revForEachVersion :: PackageName -> IO (Map. Map Version (Set PackageIdentifier ))
59
58
}
60
59
61
60
instance IsHackageFeature ReverseFeature where
@@ -86,7 +85,7 @@ initReverseFeature _ = do
86
85
return $ \ CoreFeature {queryGetPackageIndex,packageChangeHook}
87
86
VersionsFeature {queryGetPreferredVersions} -> do
88
87
idx <- queryGetPackageIndex
89
- memState <- newMemStateWHNF =<< constructReverseIndex idx
88
+ memState <- newMemStateWHNF $ constructReverseIndex idx
90
89
91
90
let feature = reverseFeature queryGetPackageIndex queryGetPreferredVersions memState updateReverse
92
91
@@ -95,9 +94,7 @@ initReverseFeature _ = do
95
94
Nothing -> return () -- PackageRemoveHook
96
95
Just pkginfo -> do
97
96
index <- queryGetPackageIndex
98
- r <- readMemState memState
99
- added <- addPackage index (packageName pkgid) (getDepNames pkginfo) r
100
- writeMemState memState added
97
+ modifyMemState memState $ addPackage index (packageName pkgid) (getDepNames pkginfo)
101
98
runHook_ updateReverse [pure pkginfo]
102
99
103
100
return feature
@@ -179,29 +176,29 @@ reverseFeature queryGetPackageIndex
179
176
queryReverseIndex :: MonadIO m => m ReverseIndex
180
177
queryReverseIndex = readMemState reverseMemState
181
178
182
- queryReverseDeps :: ( MonadIO m , MonadCatch m ) => PackageName -> m ([PackageName ], [PackageName ])
179
+ queryReverseDeps :: MonadIO m => PackageName -> m ([PackageName ], [PackageName ])
183
180
queryReverseDeps pkgname = do
184
181
ms <- readMemState reverseMemState
185
- rdeps <- getDependencies pkgname ms
186
- rdepsall <- getDependenciesFlat pkgname ms
187
- let indirect = Set. difference rdepsall rdeps
188
- return (Set. toList rdeps, Set. toList indirect)
182
+ let rdeps = getDependencies pkgname ms
183
+ rdepsall = getDependenciesFlat pkgname ms
184
+ indirect = Set. difference rdepsall rdeps
185
+ pure (Set. toList rdeps, Set. toList indirect)
189
186
190
- revPackageId :: ( MonadCatch m , MonadIO m ) => PackageId -> m ReverseDisplay
187
+ revPackageId :: MonadIO m => PackageId -> m ReverseDisplay
191
188
revPackageId pkgid = do
192
189
dispInfo <- revDisplayInfo
193
190
pkgIndex <- liftIO queryGetPackageIndex
194
191
revs <- queryReverseIndex
195
- perVersionReverse dispInfo pkgIndex revs pkgid
192
+ pure $ perVersionReverse dispInfo pkgIndex revs pkgid
196
193
197
- revPackageName :: ( MonadIO m , MonadCatch m ) => PackageName -> m ReverseDisplay
194
+ revPackageName :: MonadIO m => PackageName -> m ReverseDisplay
198
195
revPackageName pkgname = do
199
196
dispInfo <- revDisplayInfo
200
197
pkgIndex <- liftIO queryGetPackageIndex
201
198
revs <- queryReverseIndex
202
- perPackageReverse dispInfo pkgIndex revs pkgname
199
+ pure $ perPackageReverse dispInfo pkgIndex revs pkgname
203
200
204
- revJSON :: ( MonadIO m , MonadThrow m ) => m ByteString
201
+ revJSON :: IO ByteString
205
202
revJSON = do
206
203
ReverseIndex revdeps nodemap _depmap <- queryReverseIndex
207
204
let assoc = takeWhile (\ (a,_) -> a < Bimap. size nodemap) $ Arr. assocs . Gr. transposeG $ revdeps
@@ -216,50 +213,48 @@ reverseFeature queryGetPackageIndex
216
213
prefs <- liftIO queryGetPreferredVersions
217
214
return $ getDisplayInfo prefs pkgIndex
218
215
219
- renderReverseWith :: ( MonadIO m , MonadCatch m ) => PackageName -> ReverseDisplay -> (Maybe VersionStatus -> Bool ) -> m ReversePageRender
216
+ renderReverseWith :: MonadIO m => PackageName -> ReverseDisplay -> (Maybe VersionStatus -> Bool ) -> m ReversePageRender
220
217
renderReverseWith pkg rev filterFunc = do
221
218
let rev' = map fst $ Map. toList rev
222
219
directCounts <- mapM revDirectCount (pkg: rev')
223
220
let counts = zip (pkg: rev') directCounts
224
221
toRender (i, i') (pkgname, (version, status)) = if filterFunc status then (,) (i+ 1 , i') $ Just ReverseRender {
225
222
rendRevPkg = PackageIdentifier pkgname version,
226
223
rendRevStatus = status,
227
- rendRevCount = fromJust $ lookup pkgname counts
224
+ rendRevCount = fromMaybe 0 $ lookup pkgname counts
228
225
} else (,) (i, i'+ 1 ) Nothing
229
226
(res, rlist) = mapAccumL toRender (0 , 0 ) (Map. toList rev)
230
- pkgCount = fromJust $ lookup pkg counts
227
+ pkgCount = fromMaybe 0 $ lookup pkg counts
231
228
return $ ReversePageRender (catMaybes rlist) res pkgCount
232
229
233
- renderReverseRecent :: ( MonadIO m , MonadCatch m ) => PackageName -> ReverseDisplay -> m ReversePageRender
230
+ renderReverseRecent :: MonadIO m => PackageName -> ReverseDisplay -> m ReversePageRender
234
231
renderReverseRecent pkg rev = renderReverseWith pkg rev $ \ status -> case status of
235
232
Just DeprecatedVersion -> False
236
233
Nothing -> False
237
234
_ -> True
238
235
239
- renderReverseOld :: ( MonadIO m , MonadCatch m ) => PackageName -> ReverseDisplay -> m ReversePageRender
236
+ renderReverseOld :: MonadIO m => PackageName -> ReverseDisplay -> m ReversePageRender
240
237
renderReverseOld pkg rev = renderReverseWith pkg rev $ \ status -> case status of
241
238
Just DeprecatedVersion -> True
242
239
Nothing -> True
243
240
_ -> False
244
241
245
242
-- -- This could also differentiate between direct and indirect dependencies
246
243
-- -- with a bit more calculation.
247
- revPackageFlat :: ( MonadIO m , MonadCatch m ) => PackageName -> m [(PackageName , Int )]
244
+ revPackageFlat :: MonadIO m => PackageName -> m [(PackageName , Int )]
248
245
revPackageFlat pkgname = do
249
246
memState <- readMemState reverseMemState
250
- deps <- getDependenciesFlat pkgname memState
251
- let depList = Set. toList deps
252
- counts <- mapM (`getTotalCount` memState) depList
253
- return $ zip depList counts
247
+ let depList = Set. toList $ getDependenciesFlat pkgname memState
248
+ pure $ map (\ d -> (d, getTotalCount d memState)) depList
254
249
255
- revPackageStats :: ( MonadIO m , MonadCatch m ) => PackageName -> m ReverseCount
250
+ revPackageStats :: MonadIO m => PackageName -> m ReverseCount
256
251
revPackageStats pkgname = do
257
- (direct, transitive) <- getReverseCount pkgname =<< readMemState reverseMemState
252
+ (direct, transitive) <- getReverseCount pkgname <$> readMemState reverseMemState
258
253
return $ ReverseCount direct transitive
259
254
260
- revDirectCount :: ( MonadIO m , MonadCatch m ) => PackageName -> m Int
255
+ revDirectCount :: MonadIO m => PackageName -> m Int
261
256
revDirectCount pkgname = do
262
- getDirectCount pkgname =<< readMemState reverseMemState
257
+ getDirectCount pkgname <$> readMemState reverseMemState
263
258
264
259
-- This returns a list of (package name, direct dependencies, flat dependencies)
265
260
-- for all packages. An interesting fact: it even does so for packages which
@@ -270,24 +265,26 @@ reverseFeature queryGetPackageIndex
270
265
-- broken packages.
271
266
--
272
267
-- The returned list is sorted ascendingly on directCount (see ReverseCount).
273
- revCountForAllPackages :: ( MonadIO m , MonadCatch m ) => m [(PackageName , ReverseCount )]
268
+ revCountForAllPackages :: MonadIO m => m [(PackageName , ReverseCount )]
274
269
revCountForAllPackages = do
275
270
index <- liftIO queryGetPackageIndex
276
271
let pkgnames = packageNames index
277
272
counts <- mapM revPackageStats pkgnames
278
273
return . sortOn (directCount . snd ) $ zip pkgnames counts
279
274
280
- revForEachVersion :: ( MonadThrow m , MonadIO m ) => PackageName -> m (Map. Map Version (Set PackageIdentifier ))
275
+ revForEachVersion :: PackageName -> IO (Map. Map Version (Set PackageIdentifier ))
281
276
revForEachVersion pkg = do
282
- ReverseIndex revs nodemap depmap <- readMemState reverseMemState
283
- index <- liftIO queryGetPackageIndex
284
- nodeid <- Bimap. lookup pkg nodemap
285
- revDepNames <- mapM (`Bimap.lookupR` nodemap) (Set. toList $ suc revs nodeid)
286
- let -- The key is the version of 'pkg', and the values are specific
277
+ ReverseIndex revs nodemap depmap <- readMemState reverseMemState
278
+ index <- queryGetPackageIndex
279
+ let revDepNames :: [PackageName ]
280
+ revDepNames = case Bimap. lookup pkg nodemap of
281
+ Nothing -> []
282
+ Just nodeid -> mapMaybe (`Bimap.lookupR` nodemap) (Set. toList $ suc revs nodeid)
283
+ let -- The key is the version of 'pkg', and the values are specific
287
284
-- package versions that accept this version of pkg specified in the key
288
285
revDepVersions :: [(Version , Set PackageIdentifier )]
289
286
revDepVersions = do
290
287
x <- nubOrd revDepNames
291
288
pkginfo <- PackageIndex. lookupPackageName index pkg
292
289
pure (packageVersion pkginfo, dependsOnPkg index (packageId pkginfo) x depmap)
293
- pure $ Map. fromListWith Set. union revDepVersions
290
+ pure $ Map. fromListWith Set. union revDepVersions
0 commit comments