{-# LANGUAGE FlexibleContexts #-}

-- created by Jakub Travnik
--
-- see http://sandersn.com/blog//index.php/2009/11/16/imperative-programming-in-haskell
-- for context

-- This is not entirely satisfying result :-|
-- Although I like it more than original.
-- I used IOUArray and IORef instead of STUArray and STRef, but this can be easily rewritten to use that instead.
-- The insertSort function is a quite generic. If I did not have to use IORef,
-- the IO in signature could be changed to type variable so it would work with both STUArray and IOUArray.


import Data.Array.MArray
import Data.Array.IO
import Data.IORef
import Control.Monad

a @@ i = readArray a i
a @@@ i = writeArray a i

copyTo a ifrom ito = do
  x <- a @@ ifrom
  (a @@@ ito) x

arrlength a = (getBounds a) >>= \(low,high) -> return $ high-low+1

whileM condition action = condition >>= flip when (action >> whileM condition action)

tec t e c = if c then t else e

andM cond1 cond2 = cond1 >>= tec cond2 (return False)

mfmap fn m = m >>= \x -> return $ fn x

insertSort :: (MArray a e IO, Ord e) => a Int e -> IO (a Int e)
insertSort a = do
  len <- arrlength a
  forM_ [1..len-1] $ \j -> do
    key <- a @@ j
    iref <- newIORef $ j - 1
    let readi = readIORef iref 
    whileM (readi >>= \i -> (andM (return (i > -1)) (mfmap (>key) (a @@ i)))) $ do
      i <- readi
      copyTo a i (i+1)
      modifyIORef iref (subtract 1)
    i <- readi
    (a @@@ (i+1)) key
  return a

main = do
  let listToSort = [1,3,6,3,5,8,2,4]
  a <- newListArray (0,length listToSort-1) listToSort :: IO (IOUArray Int Int)
  result <- insertSort a
  resultList <- getElems a
  putStrLn $ "result: "++show resultList