{-# LANGUAGE NoMonomorphismRestriction,
             ScopedTypeVariables #-}

import Control.Arrow
import Control.Parallel.Strategies
import Control.DeepSeq
import System.IO
import Data.Time.Clock
import Text.Printf

-- wish there was a library.....
printTime name start = do
    ct <- getCurrentTime
    putStrLn $ printf "%s: %s sec." name (show $ diffUTCTime ct start)

data Tree a = Leaf a | Node (Tree a) (Tree a) deriving (Show)

instance NFData a => NFData (Tree a) where
    rnf (Leaf v) = deepseq v ()
    rnf (Node x y) = deepseq (x, y) ()

listToTree [] = error "listToTree -- empty list"
listToTree [x] = Leaf x
listToTree xs = uncurry Node $ listToTree *** listToTree $
    splitAt (length xs `div` 2) xs

-- mergeSort' :: Ord a => Tree a -> Eval [a]
mergeSort' l (Leaf v) = return [v]
mergeSort' l (Node x y) = do
    xr <- strat $ runEval $ mergeSort' (l - 1) x
    yr <- rseq $ runEval $ mergeSort' (l - 1) y
    rdeepseq (merge xr yr)
    where
        merge [] y = y
        merge x [] = x
        merge (x:xs) (y:ys) | x < y = x : merge xs (y:ys)
                            | otherwise = y : merge (x:xs) ys
        strat | l > 0 = rpar
              | otherwise = rseq

mergeSort = runEval . mergeSort' 10

main = do
    ct <- getCurrentTime
    tree :: Tree Int <- return $ listToTree [10000000,9999999..1]
    deepseq tree $ return ()
    printTime "initialization" ct
    hFlush stdout
    ct <- getCurrentTime
    deepseq (mergeSort tree) $ return ()
    printTime "sorting" ct