-- SPDX-FileCopyrightText: 2026 Alexandra de Wit
--
-- SPDX-License-Identifier: MIT
{-# LANGUAGE DeriveFunctor #-}

{- | Bounded name-prefix walks with resumable bucket cursors.
Listings have no stable order. Oversized buckets split until the depth bound.
-}
module Ecluse.Core.Registry.Sweep.Walk (
    bucketNameBudget,
    bucketDepthLimit,
    walkBuckets,
    resumeAfter,
    BucketNames (..),
    collectBucketWith,
    insertInventory,
) where

import Control.Monad (foldM)
import Data.Conduit (ConduitT, await, fuseBothMaybe, runConduit)
import Data.Map.Strict qualified as Map
import Data.Text qualified as T

import Ecluse.Core.Package (PackageName)
import Ecluse.Core.Registry.Maintenance.NameSpace (
    NameAlphabet,
    NamePrefix,
    extendBucket,
    initialBuckets,
    renderNamePrefix,
 )

-- | Maximum distinct package names held in one bucket across its target inventories.
bucketNameBudget :: Int
bucketNameBudget :: Int
bucketNameBudget = Int
10000

{- | How far a bucket may be narrowed. Past it the names share a prefix this long and narrowing
has stopped dividing them, so the walk reports rather than descending without end.
-}
bucketDepthLimit :: Int
bucketDepthLimit :: Int
bucketDepthLimit = Int
4

-- | The buckets a walk covers, in the order it covers them.
walkBuckets :: NameAlphabet -> [NamePrefix]
walkBuckets :: NameAlphabet -> [NamePrefix]
walkBuckets = NonEmpty NamePrefix -> [NamePrefix]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (NonEmpty NamePrefix -> [NamePrefix])
-> (NameAlphabet -> NonEmpty NamePrefix)
-> NameAlphabet
-> [NamePrefix]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NameAlphabet -> NonEmpty NamePrefix
initialBuckets

{- | The buckets still to cover, given the one last completed. A bucket the record falls inside is
kept, because the walk stopped part way through that bucket's own split.
-}
resumeAfter :: Maybe NamePrefix -> [NamePrefix] -> [NamePrefix]
resumeAfter :: Maybe NamePrefix -> [NamePrefix] -> [NamePrefix]
resumeAfter = ([NamePrefix] -> [NamePrefix])
-> (NamePrefix -> [NamePrefix] -> [NamePrefix])
-> Maybe NamePrefix
-> [NamePrefix]
-> [NamePrefix]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [NamePrefix] -> [NamePrefix]
forall a. a -> a
id ((NamePrefix -> Bool) -> [NamePrefix] -> [NamePrefix]
forall a. (a -> Bool) -> [a] -> [a]
filter ((NamePrefix -> Bool) -> [NamePrefix] -> [NamePrefix])
-> (NamePrefix -> NamePrefix -> Bool)
-> NamePrefix
-> [NamePrefix]
-> [NamePrefix]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamePrefix -> NamePrefix -> Bool
stillToDo)

{- A bucket is done when it sorts at or before the record without containing it. Containing it
means the record is a narrower bucket inside this one, so this one is only part done. -}
stillToDo :: NamePrefix -> NamePrefix -> Bool
stillToDo :: NamePrefix -> NamePrefix -> Bool
stillToDo NamePrefix
done NamePrefix
bucket = NamePrefix
bucket NamePrefix -> NamePrefix -> Bool
forall a. Ord a => a -> a -> Bool
> NamePrefix
done Bool -> Bool -> Bool
|| NamePrefix -> NamePrefix -> Bool
properlyCovers NamePrefix
bucket NamePrefix
done

properlyCovers :: NamePrefix -> NamePrefix -> Bool
properlyCovers :: NamePrefix -> NamePrefix -> Bool
properlyCovers NamePrefix
bucket NamePrefix
done = Text
raw Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= NamePrefix -> Text
renderNamePrefix NamePrefix
done Bool -> Bool -> Bool
&& Text
raw Text -> Text -> Bool
`T.isPrefixOf` NamePrefix -> Text
renderNamePrefix NamePrefix
done
  where
    raw :: Text
raw = NamePrefix -> Text
renderNamePrefix NamePrefix
bucket

-- | What reading one bucket's listing produced.
data BucketNames fault a
    = -- | The bucket was read whole, its names sorted.
      BucketRead [a]
    | -- | The bucket outgrew the budget, so these narrower ones cover it instead.
      BucketOverflowed (NonEmpty NamePrefix)
    | -- | The bucket outgrew the budget and nothing narrows it further.
      BucketUnsplittable
    | -- | The listing stopped on a fault, and nothing was read.
      BucketFaulted fault
    deriving stock ((forall a b.
 (a -> b) -> BucketNames fault a -> BucketNames fault b)
-> (forall a b. a -> BucketNames fault b -> BucketNames fault a)
-> Functor (BucketNames fault)
forall a b. a -> BucketNames fault b -> BucketNames fault a
forall a b. (a -> b) -> BucketNames fault a -> BucketNames fault b
forall fault a b. a -> BucketNames fault b -> BucketNames fault a
forall fault a b.
(a -> b) -> BucketNames fault a -> BucketNames fault b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall fault a b.
(a -> b) -> BucketNames fault a -> BucketNames fault b
fmap :: forall a b. (a -> b) -> BucketNames fault a -> BucketNames fault b
$c<$ :: forall fault a b. a -> BucketNames fault b -> BucketNames fault a
<$ :: forall a b. a -> BucketNames fault b -> BucketNames fault a
Functor)

-- | Merge one bucket's listing pages under the distinct-name bound, keeping each name's evidence.
collectBucketWith ::
    NameAlphabet ->
    NamePrefix ->
    (a -> a -> a) ->
    ConduitT () [(PackageName, a)] IO (Maybe fault) ->
    IO (BucketNames fault (PackageName, a))
collectBucketWith :: forall a fault.
NameAlphabet
-> NamePrefix
-> (a -> a -> a)
-> ConduitT () [(PackageName, a)] IO (Maybe fault)
-> IO (BucketNames fault (PackageName, a))
collectBucketWith NameAlphabet
alphabet NamePrefix
prefix a -> a -> a
merge ConduitT () [(PackageName, a)] IO (Maybe fault)
source = (Maybe (Maybe fault), Maybe [(PackageName, a)])
-> BucketNames fault (PackageName, a)
forall {fault} {a}.
(Maybe (Maybe fault), Maybe [a]) -> BucketNames fault a
outcome ((Maybe (Maybe fault), Maybe [(PackageName, a)])
 -> BucketNames fault (PackageName, a))
-> IO (Maybe (Maybe fault), Maybe [(PackageName, a)])
-> IO (BucketNames fault (PackageName, a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConduitT () Void IO (Maybe (Maybe fault), Maybe [(PackageName, a)])
-> IO (Maybe (Maybe fault), Maybe [(PackageName, a)])
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT () [(PackageName, a)] IO (Maybe fault)
-> ConduitT [(PackageName, a)] Void IO (Maybe [(PackageName, a)])
-> ConduitT
     () Void IO (Maybe (Maybe fault), Maybe [(PackageName, a)])
forall (m :: * -> *) a b r1 c r2.
Monad m =>
ConduitT a b m r1
-> ConduitT b c m r2 -> ConduitT a c m (Maybe r1, r2)
fuseBothMaybe ConduitT () [(PackageName, a)] IO (Maybe fault)
source ((a -> a -> a)
-> ConduitT [(PackageName, a)] Void IO (Maybe [(PackageName, a)])
forall a o.
(a -> a -> a)
-> ConduitT [(PackageName, a)] o IO (Maybe [(PackageName, a)])
takeToBudget a -> a -> a
merge))
  where
    outcome :: (Maybe (Maybe fault), Maybe [a]) -> BucketNames fault a
outcome = \case
        (Maybe (Maybe fault)
_, Maybe [a]
Nothing) -> BucketNames fault a
-> (NonEmpty NamePrefix -> BucketNames fault a)
-> Maybe (NonEmpty NamePrefix)
-> BucketNames fault a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe BucketNames fault a
forall fault a. BucketNames fault a
BucketUnsplittable NonEmpty NamePrefix -> BucketNames fault a
forall fault a. NonEmpty NamePrefix -> BucketNames fault a
BucketOverflowed ([NamePrefix] -> Maybe (NonEmpty NamePrefix)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty (NameAlphabet -> NamePrefix -> [NamePrefix]
narrowerBuckets NameAlphabet
alphabet NamePrefix
prefix))
        (Just (Just fault
fault), Maybe [a]
_) -> fault -> BucketNames fault a
forall fault a. fault -> BucketNames fault a
BucketFaulted fault
fault
        (Maybe (Maybe fault)
_, Just [a]
names) -> [a] -> BucketNames fault a
forall fault a. [a] -> BucketNames fault a
BucketRead [a]
names

{- The buckets covering this one, none where it cannot be narrowed. An alphabet with no characters
divides nothing, and past the depth bound a further character has stopped dividing the names. -}
narrowerBuckets :: NameAlphabet -> NamePrefix -> [NamePrefix]
narrowerBuckets :: NameAlphabet -> NamePrefix -> [NamePrefix]
narrowerBuckets NameAlphabet
alphabet NamePrefix
prefix
    | Text -> Int -> Ordering
T.compareLength (NamePrefix -> Text
renderNamePrefix NamePrefix
prefix) Int
bucketDepthLimit Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
/= Ordering
LT = []
    | Bool
otherwise = NameAlphabet -> NamePrefix -> [NamePrefix]
extendBucket NameAlphabet
alphabet NamePrefix
prefix

{- Fold the pages until the bucket is read or the budget is crossed. 'Nothing' means the budget
went first, which abandons the stream where it stands. -}
takeToBudget :: (a -> a -> a) -> ConduitT [(PackageName, a)] o IO (Maybe [(PackageName, a)])
takeToBudget :: forall a o.
(a -> a -> a)
-> ConduitT [(PackageName, a)] o IO (Maybe [(PackageName, a)])
takeToBudget a -> a -> a
merge = Map PackageName a
-> ConduitT [(PackageName, a)] o IO (Maybe [(PackageName, a)])
forall {m :: * -> *} {t :: * -> *} {key} {o}.
(Monad m, Foldable t, Ord key) =>
Map key a -> ConduitT (t (key, a)) o m (Maybe [(key, a)])
go Map PackageName a
forall k a. Map k a
Map.empty
  where
    go :: Map key a -> ConduitT (t (key, a)) o m (Maybe [(key, a)])
go Map key a
held =
        ConduitT (t (key, a)) o m (Maybe (t (key, a)))
forall (m :: * -> *) i o. Monad m => ConduitT i o m (Maybe i)
await ConduitT (t (key, a)) o m (Maybe (t (key, a)))
-> (Maybe (t (key, a))
    -> ConduitT (t (key, a)) o m (Maybe [(key, a)]))
-> ConduitT (t (key, a)) o m (Maybe [(key, a)])
forall a b.
ConduitT (t (key, a)) o m a
-> (a -> ConduitT (t (key, a)) o m b)
-> ConduitT (t (key, a)) o m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Maybe (t (key, a))
Nothing -> Maybe [(key, a)] -> ConduitT (t (key, a)) o m (Maybe [(key, a)])
forall a. a -> ConduitT (t (key, a)) o m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(key, a)] -> Maybe [(key, a)]
forall a. a -> Maybe a
Just (Map key a -> [(key, a)]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map key a
held))
            Just t (key, a)
page -> ConduitT (t (key, a)) o m (Maybe [(key, a)])
-> (Map key a -> ConduitT (t (key, a)) o m (Maybe [(key, a)]))
-> Maybe (Map key a)
-> ConduitT (t (key, a)) o m (Maybe [(key, a)])
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe [(key, a)] -> ConduitT (t (key, a)) o m (Maybe [(key, a)])
forall a. a -> ConduitT (t (key, a)) o m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe [(key, a)]
forall a. Maybe a
Nothing) Map key a -> ConduitT (t (key, a)) o m (Maybe [(key, a)])
go ((Map key a -> (key, a) -> Maybe (Map key a))
-> Map key a -> t (key, a) -> Maybe (Map key a)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (Int -> (a -> a -> a) -> Map key a -> (key, a) -> Maybe (Map key a)
forall key value.
Ord key =>
Int
-> (value -> value -> value)
-> Map key value
-> (key, value)
-> Maybe (Map key value)
insertInventory Int
bucketNameBudget a -> a -> a
merge) Map key a
held t (key, a)
page)

-- | Refuse a new inventory identity before insertion would cross the bound. Existing ones merge.
insertInventory :: (Ord key) => Int -> (value -> value -> value) -> Map key value -> (key, value) -> Maybe (Map key value)
insertInventory :: forall key value.
Ord key =>
Int
-> (value -> value -> value)
-> Map key value
-> (key, value)
-> Maybe (Map key value)
insertInventory Int
limit value -> value -> value
merge Map key value
held (key
key, value
value)
    | key -> Map key value -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.notMember key
key Map key value
held Bool -> Bool -> Bool
&& Map key value -> Int
forall k a. Map k a -> Int
Map.size Map key value
held Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 Int
limit = Maybe (Map key value)
forall a. Maybe a
Nothing
    | Bool
otherwise = Map key value -> Maybe (Map key value)
forall a. a -> Maybe a
Just ((value -> value -> value)
-> key -> value -> Map key value -> Map key value
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith value -> value -> value
merge key
key value
value Map key value
held)