Repeat an action for a set of elements until all succeed, or progression halts

Question

Context

I'm trying to write a function that drops a list of tables from a database (e.g., tables A, B and C). This function has the following type, it returns a list of booleans indicating whether each table was successfully dropped:

dropTables :: (IConnection conn) => conn -> [String] -> IO [Bool]

Now, imagine table C depends on table B, i.e., table B cannot be dropped while table C exists. The function will be able to drop tables A and C, but not B, and so it will return [True, False, True].

So, I wanted to write a function that takes a list of tables, and calls dropTables. If any of the operations fail, it calls dropTables again but this time only with the tables that could not be dropped in the first iteration. And so on, until either all tables have been dropped, or progression halts (i.e. all operations in a given iteration fail, due to e.g. a connection being closed)

This was my first stab at it:

dropTablesRec :: IConnection conn => conn -> [String] -> IO ()
dropTablesRec conn tables = do
  results <- dropTables conn tables
  let failures = map fst $ filter (not . snd) $ zip tables results

  unless (null failures) $
    if length failures == length tables
      then print $ "Failed to drop the following tables: " ++ intercalate ", " failures
    else dropTablesRec conn failures

I then tried to generalize the core algorithm, and remove all references to tables and database connections:

-- Repeats a given action for a set of elements, until it succeeds for all elements, or fails for all elements.
-- Elements for which the operation succeeds are not passed onto the next iteration.
-- Returns the elements for which the action failed.
repeatUntilAll :: Monad m => [a] -> ([a] -> m [Bool]) -> m [a]
repeatUntilAll xs f =
  let
    go [] = return []
    go failures
      | length failures == length xs  = return failures   -- halt
      | otherwise                     = repeatUntilAll failures f
  in
    do
      results <- f xs
      let failures = map fst $ filter (not . snd) $ zip xs results
      go failures

dropTablesRec can now be reduced to:

dropTablesRec' :: IConnection conn => conn -> [String] -> IO ()
dropTablesRec' conn tables = do
  failures <- repeatUntilAll tables (dropTables conn)
  unless (null failures) $ print $ "Failed to drop the following tables: " ++ intercalate ", " failures

I was wondering if there's a simpler way of implementing repeatUntilAll.

I had a look around Control.Monad.Loops to see if there was anything I could use, but no such luck. Being a Haskell novice doesn't help either, I'm only familiar with a very small part of the core libraries.

Other improvements (naming, conventions, greater generalization) are also welcome.

Answer 1

I quite like your aim for simplifying the function and factoring out the generic part. One solution (untested, just compiled) could be done using iterateUntilM from Control.Monad.Loops:

repeatUntilAll :: (Monad m) => ([a] -> m [Bool]) -> [a] -> m [a]
repeatUntilAll f = fmap snd . iterateUntilM fst step . ((,) True)
  where
    step (_, xs) = do
        results <- f xs
        let ys = map fst $ filter (not . snd) $ zip xs results
        return (length xs > length ys, ys)

We pass an additional boolean flag that tells if a particular step was an improvement or not. Note that we don't need to check for the final condition - if everything succeeds, there will be one final step with an empty list and then we'll stop.

However, I like a bit more yet another solution. Notice this: Let's say the first removal succeeds, the second fails and because of this, everything else. Then we iterate through the whole list, and then once more, before we finish. But in fact we know that we're bound to fail when we fail to remove all the other elements. In this second solution, we loop over all elements without distinguishing a full pass. Instead we "reset" the state every time we succeed and try all the failed elements again. I also like its simplicity, compared to the previous one:

-- | Tries to repeatedly act on each element until the action succeeds on each.
-- Alternatively stops when the action fails for all unfinished elements in one full round.
tryOnAll :: (Monad m) => (a -> m Bool) -> [a] -> m [a]
tryOnAll f = loop []
  where
    loop fs [] = return fs
    loop fs (w : ws) = do
        r <- f w
        if r then loop [] (fs ++ ws)
             else loop (w : fs) ws

(Again compiled but untested.) Note that in fs ++ ws we change the order of elements. This shouldn't be a problem, as we need to try out all before we fail anyway, but if you don't like it, you can use Seq instead of [] and maintain sequential order. Or you could also replace it with ws ++ reverse fs, but only if the total number of elements is moderate, otherwise you could start having problems with its O(n) complexity.

---

A tiny nit, unrelated to the main problem: Haddock comments allow you to generate nice documentation.

Answer 2

In repeatUntilAll inner loop go could be replaced with sequence. But you can generalize it and get compatibility with Control.Monad.Loops:

loopAllWith :: Monad m => ([a] -> m [Bool]) -> [a] -> m [a]
loopAllWith run = loop
  where
    loop xs = do
      ys <- run xs
      if any id ys
        then return xs
        else loop [x | (False, x) <- zip ys xs]

-- run tasks sequentially
loopAllSeq :: Monad m => (a -> m Bool) -> [a] -> m [a]
loopAllSeq f = loopAllWith $ sequence . map f

-- run tasks in parallel using `Control.Monad.Loops.forkMapM`
loopAllPar :: (a -> IO Bool) -> [a] -> IO [a]
loopAllPar f = loopAllWith
  $ map (either (const False) id) <.> forkMapM f
  where
    f <.> g = fmap f . g

Now you can drop tables like this:

dropTable :: IConnection c => c -> TableName -> IO Bool
dropTable = ...

dropTables :: IConnection c => c -> [TableName] -> IO [TableName]
dropTables = loopAllPar . dropTable

---

Side note about style. let .. in do .. is ugly but you can let in your dos:

repeatUntilAll :: Monad m => [a] -> ([a] -> m [Bool]) -> m [a]
repeatUntilAll xs f = do
  let go [] = return []
      go failures
        | length failures == length xs  = return failures   -- halt
        | otherwise                     = repeatUntilAll failures f
  results <- f xs
  let failures = map fst $ filter (not . snd) $ zip xs results
  go failures