in-place insertion sort

Main.hs

{-# LANGUAGE BangPatterns, CPP, MagicHash, UnboxedTuples #-}

module Main where

import Control.Monad (forM_)
import GHC.Enum
import GHC.Types
import GHC.Prim
import GHC.Word

{-
-- From "The Algorithm Design Manual" by Steven S Skiena:

insertion_sort(item s[], int n)
{
    int i,j;                /* counters */
    for (i=1; i<n; i++) {
       j=i;
       while ((j>0) && (s[j] < s[j-1])) {
           swap(&s[j],&s[j-1]);
           j = j-1;
       }
    }
}
-}

-- From ghc/testsuite/tests/lib/integer/integerGmpInternals.hs 
-- 8>< - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
data MBA = MBA { unMBA :: !(MutableByteArray# RealWorld) }
data BA  = BA  { unBA  :: !ByteArray# }

newByteArray :: Word# -> IO MBA
newByteArray sz = IO $ \s ->
  case newPinnedByteArray# (word2Int# sz) s of
    (# s, arr #) -> (# s, MBA arr #)

writeByteArray :: MutableByteArray# RealWorld -> Int# -> Word8 -> IO ()
writeByteArray arr i (W8# w) = IO $ \s ->
  case writeWord8Array# arr i w s of
    s -> (# s, () #)

lengthByteArray :: ByteArray# -> Word
lengthByteArray ba = W# (int2Word# (sizeofByteArray# ba))

indexByteArray :: ByteArray# -> Word# -> Word8
indexByteArray a# n# = W8# (indexWord8Array# a# (word2Int# n#))

unpackByteArray :: ByteArray# -> [Word8]
unpackByteArray ba | n == 0    = []
                   | otherwise = [ indexByteArray ba i | W# i <- [0 .. n-1] ]
  where
    n = lengthByteArray ba

freezeByteArray :: MutableByteArray# RealWorld -> IO BA
freezeByteArray arr = IO $ \s ->
  case unsafeFreezeByteArray# arr s of
    (# s, arr #) -> (# s, BA arr #)
-- 8>< - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

-- XXX: 'IO ()' can be generalized to 'IO a'.
for :: Int -> (Int -> Int) -> (Int -> IO Bool) -> (Int -> IO ()) -> IO () 
for i f p act = do
  b <- p i
  if b
  then act i >> for (f i) f p act
  else return ()

fromInt# :: Int# -> Int
fromInt# = I#

toInt# :: Int -> Int#
toInt# (I# i) = i

toWord8# :: Word8 -> Word#
toWord8# (W8# w) = w

fromWord8# :: Word# -> Word8
fromWord8# = W8#

initByteArray :: [Word8] -> Word -> IO MBA
initByteArray xs (W# n) = do 
  MBA mba <- newByteArray n
  let n' = fromInt# (word2Int# n)
  forM_ (zip [0..n'-1] xs) $ \(i, w) ->
    writeByteArray mba (toInt# i) w
  return (MBA mba)

swapByteArray :: MutableByteArray# RealWorld -> Int# -> Int# -> IO ()
swapByteArray arr i j = IO $ \s ->
  case readWord8Array# arr i s of
    (# s', wi #) -> case readWord8Array# arr j s' of
      (# s'', wj #) -> case writeWord8Array# arr j wi s'' of
        s''' -> (# writeWord8Array# arr i wj s''', () #)

{- XXX: Is it necessary to freeze before printing?

    • Couldn't match a lifted type with an unlifted type
      Expected type: (# State# RealWorld, Word# #)
        Actual type: (# State# RealWorld, Word# #)
    • In the expression: readWord8Array# arr i s
      In the second argument of ‘($)’, namely
        ‘\ s -> readWord8Array# arr i s’
      In a stmt of a 'do' block:
        i' <- IO $ \ s -> readWord8Array# arr i s
   |
80 |        i' <- IO $ \s -> readWord8Array# arr i s
   |                         ^^^^^^^^^^^^^^^^^^^^^^^

printByteArray :: MutableByteArray# RealWorld -> Word -> IO ()
printByteArray arr (W# n) =
  let n' = fromInt# (word2Int# n)
  in forM_ [0..n'-1] $ \(I# i) -> do
       i' <- IO $ \s -> readWord8Array# arr i s
       print i'
-}

indexWord8Array :: MutableByteArray# RealWorld -> Int# -> IO Word8
indexWord8Array arr i = IO $ \s ->
  case readWord8Array# arr i s of
    (# s', wi #) -> (# s', W8# wi #)

main :: IO ()
main = do
  let s = [5,3,2,4,1]
      n = length s

  BA ba <- do
    MBA mba <- initByteArray s (toEnum n)
    for 1 (+ 1) (\i -> return $ i < n) $ \i -> do
      print $ "i: " ++ show i
      let j = i
      for j (\j -> j - 1) (\j -> do
        x <- indexWord8Array mba (toInt# j)
        y <- indexWord8Array mba (toInt# (j - 1))
        return $ j > 0 && (x < y)) $ \j -> do
        print $ "j: " ++ show j
        swapByteArray mba (toInt# j) (toInt# (j - 1))
    freezeByteArray mba

  print $ unpackByteArray ba