Skip to content

Commit 6384905

Browse files
authored
cleanup buncha partial functions for revdeps, elim use of MonadThrow (#1156)
* cleanup partial functions for revdeps, elim use of MonadThrow, MonadCatch * fix tests enablement link
1 parent b13bc6e commit 6384905

File tree

6 files changed

+129
-166
lines changed

6 files changed

+129
-166
lines changed

benchmarks/RevDeps.hs

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -62,15 +62,15 @@ main :: IO ()
6262
main = do
6363
packs :: Vector.Vector (Package TestPackage) <- randomPacks globalStdGen 20000 mempty
6464
let idx = PackageIndex.fromList $ map packToPkgInfo (Vector.toList packs)
65-
Right revs <- pure $ constructReverseIndex idx
65+
let revs = constructReverseIndex idx
6666
let numPacks = length packs
6767
defaultMain $
6868
(:[]) $
6969
bench "get transitive dependencies for one randomly selected package" $
7070
flip nfAppIO revs $ \revs' -> do
7171
select <- uniformRM (0, numPacks - 1) globalStdGen
7272
-- TODO why are there so many transitive deps?
73-
length <$>
73+
pure $ length $
7474
getDependenciesFlat
7575
(packageName $ packToPkgInfo (packs Vector.! select))
7676
revs'

datafiles/templates/Html/maintain.html.st

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -48,7 +48,7 @@ package after its been released.
4848

4949
<dt>Test settings</dt>
5050
<dd>If your package contains tests that can't run on hackage, you can disable them here.
51-
<p>$versions:{pkgid|<a href="/package/$pkgid$/reports/test">$pkgid$</a>}; separator=", "$</p>
51+
<p>$versions:{pkgid|<a href="/package/$pkgid$/reports/testsEnabled">$pkgid$</a>}; separator=", "$</p>
5252
</dd>
5353

5454
<dt>Trigger rebuild</dt>

src/Distribution/Server/Features/Html.hs

Lines changed: 9 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -232,7 +232,7 @@ htmlFeature :: ServerEnv
232232
-> AsyncCache Response
233233
-> AsyncCache Response
234234
-> Templates
235-
-> RecentPackagesFeature
235+
-> RecentPackagesFeature
236236
-> (HtmlFeature, IO Response, IO Response)
237237

238238
htmlFeature env@ServerEnv{..}
@@ -526,7 +526,7 @@ mkHtmlCore ServerEnv{serverBaseURI, serverBlobStore}
526526
}
527527
]
528528

529-
readParamWithDefaultAndValid :: (Read a, HasRqData m, Monad m, Functor m, Alternative m) =>
529+
readParamWithDefaultAndValid :: (Read a, HasRqData m, Monad m, Functor m, Alternative m) =>
530530
a -> (a -> Bool) -> String -> m a
531531
readParamWithDefaultAndValid n f queryParam = do
532532
m <- optional (look queryParam)
@@ -550,7 +550,7 @@ mkHtmlCore ServerEnv{serverBaseURI, serverBlobStore}
550550
pageSize <- lookupPageSize 20
551551

552552
let conf = Paging.createConf page pageSize recentPackages
553-
553+
554554
return . toResponse $ Pages.recentPage conf users recentPackages
555555

556556
serveRecentRSS :: DynamicPath -> ServerPartE Response
@@ -560,9 +560,9 @@ mkHtmlCore ServerEnv{serverBaseURI, serverBlobStore}
560560
page <- lookupPage 1
561561
pageSize <- lookupPageSize 20
562562
now <- liftIO getCurrentTime
563-
563+
564564
let conf = Paging.createConf page pageSize recentPackages
565-
565+
566566
return . toResponse $ Pages.recentFeed conf users serverBaseURI now recentPackages
567567

568568
serveRevisionPage :: DynamicPath -> ServerPartE Response
@@ -571,7 +571,7 @@ mkHtmlCore ServerEnv{serverBaseURI, serverBlobStore}
571571
users <- queryGetUserDb
572572
page <- lookupPage 1
573573
pageSize <- lookupPageSize 40
574-
574+
575575
let conf = Paging.createConf page pageSize revisions
576576

577577
return . toResponse $ Pages.revisionsPage conf users revisions
@@ -583,7 +583,7 @@ mkHtmlCore ServerEnv{serverBaseURI, serverBlobStore}
583583
page <- lookupPage 1
584584
pageSize <- lookupPageSize 40
585585
now <- liftIO getCurrentTime
586-
586+
587587
let conf = Paging.createConf page pageSize revisions
588588

589589
return . toResponse $ Pages.recentRevisionsFeed conf users serverBaseURI now revisions
@@ -614,7 +614,7 @@ mkHtmlCore ServerEnv{serverBaseURI, serverBlobStore}
614614

615615
serveGraphJSON :: DynamicPath -> ServerPartE Response
616616
serveGraphJSON _ = do
617-
graph <- revJSON
617+
graph <- liftIO revJSON
618618
--TODO: use proper type for graph with ETag
619619
cacheControl [Public, maxAgeMinutes 30] (etagFromHash graph)
620620
ok . toResponse $ graph
@@ -2178,7 +2178,7 @@ mkHtmlReverse HtmlUtilities{..}
21782178
let pkgname = pkgName pkg
21792179
pkgids <- lookupPackageName pkgname
21802180
revCount <- revPackageStats pkgname
2181-
versions <- revForEachVersion pkgname
2181+
versions <- liftIO $ revForEachVersion pkgname
21822182
return $ toResponse $ Resource.XHtml $ hackagePage (display pkgname ++ " - Reverse dependency statistics") $
21832183
reverseVerboseRender pkgname (map packageVersion pkgids) (corePackageIdUri "") revCount versions
21842184

src/Distribution/Server/Features/ReverseDependencies.hs

Lines changed: 46 additions & 49 deletions
Original file line numberDiff line numberDiff line change
@@ -21,13 +21,12 @@ import Distribution.Package
2121
import Distribution.Text (display)
2222
import Distribution.Version (Version)
2323

24-
import Control.Monad.Catch (MonadThrow, MonadCatch)
2524
import Data.Aeson
2625
import Data.ByteString.Lazy (ByteString)
2726
import Data.Containers.ListUtils (nubOrd)
2827
import Data.List (mapAccumL, sortOn)
2928
import qualified Data.List.NonEmpty as NE
30-
import Data.Maybe (catMaybes, fromJust)
29+
import Data.Maybe (catMaybes, mapMaybe, fromMaybe)
3130
import Data.Function (fix)
3231
import qualified Data.Bimap as Bimap
3332
import qualified Data.Array as Arr
@@ -44,18 +43,18 @@ data ReverseFeature = ReverseFeature {
4443

4544
reverseHook :: Hook [NE.NonEmpty PkgInfo] (),
4645

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,
5756
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))
5958
}
6059

6160
instance IsHackageFeature ReverseFeature where
@@ -86,7 +85,7 @@ initReverseFeature _ = do
8685
return $ \CoreFeature{queryGetPackageIndex,packageChangeHook}
8786
VersionsFeature{queryGetPreferredVersions} -> do
8887
idx <- queryGetPackageIndex
89-
memState <- newMemStateWHNF =<< constructReverseIndex idx
88+
memState <- newMemStateWHNF $ constructReverseIndex idx
9089

9190
let feature = reverseFeature queryGetPackageIndex queryGetPreferredVersions memState updateReverse
9291

@@ -95,9 +94,7 @@ initReverseFeature _ = do
9594
Nothing -> return () --PackageRemoveHook
9695
Just pkginfo -> do
9796
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)
10198
runHook_ updateReverse [pure pkginfo]
10299

103100
return feature
@@ -179,29 +176,29 @@ reverseFeature queryGetPackageIndex
179176
queryReverseIndex :: MonadIO m => m ReverseIndex
180177
queryReverseIndex = readMemState reverseMemState
181178

182-
queryReverseDeps :: (MonadIO m, MonadCatch m) => PackageName -> m ([PackageName], [PackageName])
179+
queryReverseDeps :: MonadIO m => PackageName -> m ([PackageName], [PackageName])
183180
queryReverseDeps pkgname = do
184181
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)
189186

190-
revPackageId :: (MonadCatch m, MonadIO m) => PackageId -> m ReverseDisplay
187+
revPackageId :: MonadIO m => PackageId -> m ReverseDisplay
191188
revPackageId pkgid = do
192189
dispInfo <- revDisplayInfo
193190
pkgIndex <- liftIO queryGetPackageIndex
194191
revs <- queryReverseIndex
195-
perVersionReverse dispInfo pkgIndex revs pkgid
192+
pure $ perVersionReverse dispInfo pkgIndex revs pkgid
196193

197-
revPackageName :: (MonadIO m, MonadCatch m) => PackageName -> m ReverseDisplay
194+
revPackageName :: MonadIO m => PackageName -> m ReverseDisplay
198195
revPackageName pkgname = do
199196
dispInfo <- revDisplayInfo
200197
pkgIndex <- liftIO queryGetPackageIndex
201198
revs <- queryReverseIndex
202-
perPackageReverse dispInfo pkgIndex revs pkgname
199+
pure $ perPackageReverse dispInfo pkgIndex revs pkgname
203200

204-
revJSON :: (MonadIO m, MonadThrow m) => m ByteString
201+
revJSON :: IO ByteString
205202
revJSON = do
206203
ReverseIndex revdeps nodemap _depmap <- queryReverseIndex
207204
let assoc = takeWhile (\(a,_) -> a < Bimap.size nodemap) $ Arr.assocs . Gr.transposeG $ revdeps
@@ -216,50 +213,48 @@ reverseFeature queryGetPackageIndex
216213
prefs <- liftIO queryGetPreferredVersions
217214
return $ getDisplayInfo prefs pkgIndex
218215

219-
renderReverseWith :: (MonadIO m, MonadCatch m) => PackageName -> ReverseDisplay -> (Maybe VersionStatus -> Bool) -> m ReversePageRender
216+
renderReverseWith :: MonadIO m => PackageName -> ReverseDisplay -> (Maybe VersionStatus -> Bool) -> m ReversePageRender
220217
renderReverseWith pkg rev filterFunc = do
221218
let rev' = map fst $ Map.toList rev
222219
directCounts <- mapM revDirectCount (pkg:rev')
223220
let counts = zip (pkg:rev') directCounts
224221
toRender (i, i') (pkgname, (version, status)) = if filterFunc status then (,) (i+1, i') $ Just ReverseRender {
225222
rendRevPkg = PackageIdentifier pkgname version,
226223
rendRevStatus = status,
227-
rendRevCount = fromJust $ lookup pkgname counts
224+
rendRevCount = fromMaybe 0 $ lookup pkgname counts
228225
} else (,) (i, i'+1) Nothing
229226
(res, rlist) = mapAccumL toRender (0, 0) (Map.toList rev)
230-
pkgCount = fromJust $ lookup pkg counts
227+
pkgCount = fromMaybe 0 $ lookup pkg counts
231228
return $ ReversePageRender (catMaybes rlist) res pkgCount
232229

233-
renderReverseRecent :: (MonadIO m, MonadCatch m) => PackageName -> ReverseDisplay -> m ReversePageRender
230+
renderReverseRecent :: MonadIO m => PackageName -> ReverseDisplay -> m ReversePageRender
234231
renderReverseRecent pkg rev = renderReverseWith pkg rev $ \status -> case status of
235232
Just DeprecatedVersion -> False
236233
Nothing -> False
237234
_ -> True
238235

239-
renderReverseOld :: (MonadIO m, MonadCatch m) => PackageName -> ReverseDisplay -> m ReversePageRender
236+
renderReverseOld :: MonadIO m => PackageName -> ReverseDisplay -> m ReversePageRender
240237
renderReverseOld pkg rev = renderReverseWith pkg rev $ \status -> case status of
241238
Just DeprecatedVersion -> True
242239
Nothing -> True
243240
_ -> False
244241

245242
-- -- This could also differentiate between direct and indirect dependencies
246243
-- -- with a bit more calculation.
247-
revPackageFlat :: (MonadIO m, MonadCatch m) => PackageName -> m [(PackageName, Int)]
244+
revPackageFlat :: MonadIO m => PackageName -> m [(PackageName, Int)]
248245
revPackageFlat pkgname = do
249246
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
254249

255-
revPackageStats :: (MonadIO m, MonadCatch m) => PackageName -> m ReverseCount
250+
revPackageStats :: MonadIO m => PackageName -> m ReverseCount
256251
revPackageStats pkgname = do
257-
(direct, transitive) <- getReverseCount pkgname =<< readMemState reverseMemState
252+
(direct, transitive) <- getReverseCount pkgname <$> readMemState reverseMemState
258253
return $ ReverseCount direct transitive
259254

260-
revDirectCount :: (MonadIO m, MonadCatch m) => PackageName -> m Int
255+
revDirectCount :: MonadIO m => PackageName -> m Int
261256
revDirectCount pkgname = do
262-
getDirectCount pkgname =<< readMemState reverseMemState
257+
getDirectCount pkgname <$> readMemState reverseMemState
263258

264259
-- This returns a list of (package name, direct dependencies, flat dependencies)
265260
-- for all packages. An interesting fact: it even does so for packages which
@@ -270,24 +265,26 @@ reverseFeature queryGetPackageIndex
270265
-- broken packages.
271266
--
272267
-- 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)]
274269
revCountForAllPackages = do
275270
index <- liftIO queryGetPackageIndex
276271
let pkgnames = packageNames index
277272
counts <- mapM revPackageStats pkgnames
278273
return . sortOn (directCount . snd) $ zip pkgnames counts
279274

280-
revForEachVersion :: (MonadThrow m, MonadIO m) => PackageName -> m (Map.Map Version (Set PackageIdentifier))
275+
revForEachVersion :: PackageName -> IO (Map.Map Version (Set PackageIdentifier))
281276
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
287284
-- package versions that accept this version of pkg specified in the key
288285
revDepVersions :: [(Version, Set PackageIdentifier)]
289286
revDepVersions = do
290287
x <- nubOrd revDepNames
291288
pkginfo <- PackageIndex.lookupPackageName index pkg
292289
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

Comments
 (0)