Semi-parallel pseudo-randomized in-place quicksort in Haskell.

QuickSort.hs

{-# LANGUAGE UnicodeSyntax #-}
module Main (main) where

import Control.Applicative ((<$>))
import Control.Monad (foldM, when)
import Control.Monad.ST (ST)
import Control.Parallel (par)
import Data.Array (elems)
import Data.Array.ST (STArray, newListArray, readArray, runSTArray, writeArray)
import Data.Char (toUpper)
import Data.Maybe (fromJust)
import System.Environment (getArgs)
import System.IO (hSetBuffering, BufferMode(LineBuffering, NoBuffering), stdout, stdin)
import System.Random (randomRIO)
import System.IO.Unsafe (unsafePerformIO)
import qualified Data.ByteString.Lazy.Char8 as BS

main ∷ IO ()
main = do
  hSetBuffering stdout NoBuffering
  hSetBuffering stdin NoBuffering
  putStr "Reading input… "
  φ:_ ← getArgs
  xs ← map (fst . fromJust . BS.readInt) . BS.lines <$> BS.readFile φ
  putStrLn "Ok!"
  putStr "Sorting array… "
  let ys = sort xs
  ys `seq` putStrLn "Ok!"
  putStr "Print array [y/N]: "
  ς ← getChar
  when (toUpper ς == 'Y') $ do
    hSetBuffering stdout LineBuffering
    print ys
  putStrLn ""

sort ∷ Ord α ⇒ [α] → [α]
sort xs = elems $ runSTArray $ do
  μ ← newListArray (1, τ) xs
  sortST μ 1 τ
  where τ = length xs

sortST ∷ Ord α ⇒ STArray s Int α → Int → Int → ST s (STArray s Int α)
sortST μ ν τ
  | τ - ν < 1 = return μ
  | otherwise = do
      ι ← partition μ ν τ
      sortST μ ν (pred ι) `par` sortST μ (succ ι) τ

partition ∷ Ord α ⇒ STArray s Int α → Int → Int → ST s Int
partition μ ν τ = do
  let i = randomPivotIndex
  π ← readArray μ i
  swapArray μ ν i
  ι ← foldM (swaps π) ν [succ ν..τ]
  swapArray μ ν ι
  return ι
  where swaps π α β = do
          φ ← readArray μ β
          if (φ < π)
            then do
              swapArray μ (succ α) β
              return (succ α)
            else
              return α

        randomPivotIndex = unsafePerformIO $ randomRIO (ν, τ)

swapArray ∷ STArray s Int α → Int → Int → ST s ()
swapArray μ α β = do
  γ ← readArray μ α
  δ ← readArray μ β
  writeArray μ α δ
  writeArray μ β γ