Infinite loop in bubble sort over Traversable in Haskell

Question

I am trying to implement a bubble sort over any traversable container using the Tardis monad.

{-# LANGUAGE TupleSections #-}

module Main where

import Control.DeepSeq
import Control.Monad.Tardis
import Data.Bifunctor
import Data.Traversable
import Data.Tuple
import Debug.Trace

newtype Finished = Finished { isFinished :: Bool }

instance Monoid Finished where
  mempty = Finished False
  mappend (Finished a) (Finished b) = Finished (a || b)

-- | A single iteration of bubble sort over a list.
-- If the list is unmodified, return 'Finished' 'True', else 'False'
bubble :: Ord a => [a] -> (Finished, [a])
bubble (x:y:xs)
  | x <= y = bimap id                       (x:) (bubble (y:xs))
  | x  > y = bimap (const $ Finished False) (y:) (bubble (x:xs))
bubble as = (Finished True, as)

-- | A single iteration of bubble sort over a 'Traversable'.
-- If the list is unmodified, return 'Finished' 'True', else 'Finished' 'False'
bubbleTraversable :: (Traversable t, Ord a, NFData a, Show a) => t a -> (Finished, t a)
bubbleTraversable t = extract $ flip runTardis (initFuture, initPast) $ forM t $ \here -> do
  sendPast (Just here)
  (mp, finished) <- getPast
  -- For the first element use the first element,
  -- else the biggest of the preceding.
  let this = case mp of { Nothing -> here; Just a -> a }
  mf <- force <$> getFuture -- Tardis uses lazy pattern matching,
                            -- so force has no effect here, I guess.
  traceM "1"
  traceShowM mf -- Here the program enters an infinite loop.
  traceM "2"
  case mf of
    Nothing -> do
      -- If this is the last element, there is nothing to do.
      return this
    Just next -> do
      if this <= next
        -- Store the smaller element here
        -- and give the bigger into the future.
        then do
          sendFuture (Just next, finished)
          return this
        else do
          sendFuture (Just this, Finished False)
          return next
  where
    extract :: (Traversable t) => (t a, (Maybe a, (Maybe a, Finished))) -> (Finished, t a)
    extract = swap . (snd . snd <$>)

    initPast = (Nothing, Finished True)
    initFuture = Nothing

-- | Sort a list using bubble sort.
sort :: Ord a => [a] -> [a]
sort = snd . head . dropWhile (not . isFinished . fst) . iterate (bubble =<<) . (Finished False,)

-- | Sort a 'Traversable' using bubble sort.
sortTraversable :: (Traversable t, Ord a, NFData a, Show a) => t a -> t a
sortTraversable = snd . head . dropWhile (not . isFinished . fst) . iterate (bubbleTraversable =<<) . (Finished False,)

main :: IO ()
main = do
  print $ sort ([1,4,2,5,2,5,7,3,2] :: [Int]) -- works like a charm
  print $ sortTraversable ([1,4,2,5,2,5,7,3,2] :: [Int]) -- breaks

The main difference between bubble and bubbleTraversable is the handling of the Finished flag: In bubble we assume that the right-most element is already sorted and change the flag, if the elements to the left of it aren't; in bubbleTraversable we do it the other way around.

While trying to evaluate mf in bubbleTraversablethe program enters an infinite loop in the lazy references as evidenced by the ghc output <<loop>>.

The problem is probably, that forM tries to evaluate the elements successively, before the monadic chaining takes place (especially since forM is flip traverse for lists). Is there any way to rescue this implementation?

Answer 1

First of all, style-wise, Finished = Data.Monoid.Any (but you only use the Monoid bit for (bubble =<<) when it may as well be bubble . snd, so I just dropped it for Bool), head . dropWhile (not . isFinished . fst) = fromJust . find (isFinished . fst), case x of { Nothing -> default; Just t = f t } = maybe default f x, and maybe default id = fromMaybe default.

Second, your assumption that force does nothing in Tardis is wrong. Thunks don't "remember" they were created in a lazy-pattern match. force itself does nothing, but when the thunk it produces is evaluated, it causes the thunk it was given to be evaluated to NF, no exceptions. In your case, that case mf of ... evaluates mf to normal form (instead of just WHNF) because mf has force in it. I don't believe it's causing any problems here, though.

The real problem is that you are "deciding what to do" depending on a future value. This means you are matching on a future value, and then you are using that future value to produce a Tardis computation that gets (>>=)'d into the one that produces that value. This is a no-no. If it's any clearer: runTardis (do { x <- getFuture; x `seq` return () }) ((),()) = _|_ but runTardis (do { x <- getFuture; return $ x `seq` () }) ((),()) = ((),((),())). You are allowed to use a future value to create a pure value, but you cannot use it to decide the Tardis you will run. In your code, this is when you try case mf of { Nothing -> do ...; Just x -> do ... }.

This also means that traceShowM is causing an issue all by itself, as printing something in IO evaluates it deeply (traceShowM is approximately unsafePerformIO . (return () <$) . print). mf needs to be evaluated as the unsafePerformIO is executing, but mf depends on evaluating the Tardis operations that come after the traceShowM, but traceShowM forces the print to be done before it allows the next Tardis operation (return ()) to be revealed. <<loop>>!

Here's the fixed version:

{-# LANGUAGE TupleSections #-}

module Main where

import Control.Monad
import Control.Monad.Tardis
import Data.Bifunctor
import Data.Tuple
import Data.List hiding (sort)
import Data.Maybe

-- | A single iteration of bubble sort over a list.
-- If the list is unmodified, return 'True', else 'False'
bubble :: Ord a => [a] -> (Bool, [a])
bubble (x:y:xs)
  | x <= y = bimap id            (x:) (bubble (y:xs))
  | x  > y = bimap (const False) (y:) (bubble (x:xs))
bubble as = (True, as)

-- | A single iteration of bubble sort over a 'Traversable'.
-- If the list is unmodified, return 'True', else 'False'
bubbleTraversable :: (Traversable t, Ord a) => t a -> (Bool, t a)
bubbleTraversable t = extract $ flip runTardis init $ forM t $ \here -> do
  -- Give the current element to the past so it will have sent us biggest element
  -- so far seen. 
  sendPast (Just here)
  (mp, finished) <- getPast
  let this = fromMaybe here mp


  -- Given this element in the present and that element from the future,
  -- swap them if needed.
  -- force is fine here
  mf <- getFuture
  let (this', that', finished') = fromMaybe (this, mf, finished) $ do
                                    that <- mf
                                    guard $ that < this
                                    return (that, Just this, False)

  -- Send the bigger element back to the future
  -- Can't use mf to decide whether or not you sendFuture, but you can use it
  -- to decide WHAT you sendFuture.
  sendFuture (that', finished')

  -- Replace the element at this location with the one that belongs here
  return this'
  where
    -- No need to be clever
    extract (a, (_, (_, b))) = (b, a)
    init = (Nothing, (Nothing, True))

-- | Sort a list using bubble sort.
sort :: Ord a => [a] -> [a]
sort = snd . fromJust . find fst . iterate (bubble . snd) . (False,)

-- | Sort a 'Traversable' using bubble sort.
sortTraversable :: (Traversable t, Ord a) => t a -> t a
sortTraversable = snd . fromJust . find fst . iterate (bubbleTraversable . snd) . (False,)

main :: IO ()
main = do
  print $ sort ([1,4,2,5,2,5,7,3,2] :: [Int]) -- works like a charm
  print $ sortTraversable ([1,4,2,5,2,5,7,3,2] :: [Int]) -- works like a polymorphic charm

-- Demonstration that force does work in Tardis
checkForce = fst $ sortTraversable [(1, ""), (2, undefined)] !! 1
-- checkForce = 2 if there is no force
-- checkForce = _|_ if there is a force

If you still want to trace mf, you can mf <- traceShowId <$> getFuture, but you may not get any well-defined order to the messages (don't expect time to make sense inside a Tardis!), though in this case it seems to just print the tails of the lists backwards.