Haskell, nixOS script to bubble sort using ST monad,

bubble-sort-st-monad.hs

#!/usr/bin/env nix-shell
#!nix-shell --pure -p "haskellPackages.ghcWithPackages(pkgs:[pkgs.text pkgs.bytestring pkgs.array pkgs.containers pkgs.mtl])" -i runghc

-- \|
-- bubble sort array using ST monad
{-# LANGUAGE LambdaCase #-}

import Control.Monad
import Control.Monad.ST
import Data.Array.IArray
import Data.IntMap.Strict
import Data.STRef (STRef, modifySTRef, newSTRef, readSTRef, writeSTRef)

until_ :: (Monad m) => m a -> m Bool -> m ()
until_ action predicateM = do
  action >> predicateM >>= \case
    True -> until_ action predicateM
    False -> pure ()

testUntil_ :: IO Bool
testUntil_ =
  readLn
    >>= ( \l ->
            if l == "stop"
              then return False
              else return True
        )

bsort :: (Ord a) => [a] -> ST s [a]
bsort list = do
  (dict :: IntMap (STRef s a)) <- fromList <$> (zip [0 ..] <$> mapM newSTRef list)
  refLast <- newSTRef $ (size dict - 2)
  swapState <- newSTRef False
  until_ (bubble swapState refLast dict) (isSortCompleted swapState refLast)

  traverse readSTRef (Data.IntMap.Strict.elems dict)
  where
    bubble :: (Ord a) => STRef s Bool -> STRef s Int -> IntMap (STRef s a) -> ST s ()
    bubble swapState refLast dict = do
      lastNdx <- readSTRef refLast
      writeSTRef swapState False
      forM_ [0 .. lastNdx] $ \i -> do
        let e = findWithDefault (error "no index") i dict
            e' = findWithDefault (error ("no index: " <> show (i + 1))) (i + 1) dict
        xchgSTRefsWhen (\x y -> x > y) e e' swapState
      modifySTRef refLast (flip (-) 1)

    isSortCompleted
      :: (STRef s Bool)
      -> (STRef s Int)
      -> ST s (Bool)
    isSortCompleted swapState lastRef = do
      ndx <- readSTRef lastRef
      isSwap <- readSTRef swapState
      if ndx == -1 || not isSwap
        then pure False
        else pure True

    xchgSTRefsWhen :: (a -> a -> Bool) -> (STRef s a) -> (STRef s a) -> (STRef s Bool) -> ST s ()
    xchgSTRefsWhen predicate stref stref' swapState = do
      a <- readSTRef stref
      a' <- readSTRef stref'
      case predicate a a' of
        True -> writeSTRef stref a' >> writeSTRef stref' a >> writeSTRef swapState True
        False -> writeSTRef swapState False

main :: IO ()
main = print $ runST $ bsort [10, 9, 8, 7, 0, 4, 5, 3, 1, 2]

usage:

chmod 755 ./bubble-sort-st-monad.hs
./bubble-sort-st-monad

should print:

[0,1,2,3,4,5,7,8,9,10]