Trees!

space.txt

Case            Allocated    GCs
1000 sort         636,000      1
10000 sort      6,971,800     13
100000 sort    77,884,680    149
1000000 sort  847,753,632  1,622

time.txt

benchmarking Tree/1000
time                 212.8 μs   (202.0 μs .. 222.9 μs)
                     0.987 R²   (0.980 R² .. 0.993 R²)
mean                 197.0 μs   (190.7 μs .. 204.0 μs)
std dev              21.97 μs   (19.60 μs .. 27.46 μs)
variance introduced by outliers: 84% (severely inflated)

benchmarking Tree/10000
time                 3.531 ms   (3.398 ms .. 3.675 ms)
                     0.959 R²   (0.931 R² .. 0.980 R²)
mean                 3.649 ms   (3.431 ms .. 3.991 ms)
std dev              864.7 μs   (611.4 μs .. 1.295 ms)
variance introduced by outliers: 91% (severely inflated)

benchmarking Tree/100000
time                 35.92 ms   (33.24 ms .. 37.77 ms)
                     0.988 R²   (0.976 R² .. 0.995 R²)
mean                 37.55 ms   (35.96 ms .. 39.22 ms)
std dev              3.231 ms   (2.401 ms .. 4.366 ms)
variance introduced by outliers: 32% (moderately inflated)

benchmarking Tree/1000000
time                 356.3 ms   (326.6 ms .. 434.8 ms)
                     0.991 R²   (0.968 R² .. 1.000 R²)
mean                 369.4 ms   (348.8 ms .. 384.8 ms)
std dev              23.56 ms   (0.0 s .. 26.74 ms)
variance introduced by outliers: 19% (moderately inflated)

Tree.hs

module Data.Tree where

import Data.Monoid

data KeyValue k v = KeyValue k v

instance (Show k, Show v) => Show (KeyValue k v) where
  show (KeyValue k v) = "(" ++ show k ++ ", " ++ show v ++ ")"

instance (Eq k) => Eq (KeyValue k v) where
  (KeyValue k _) == (KeyValue k' _) = k == k'

instance (Ord k) => Ord (KeyValue k v) where
  (KeyValue a _) `compare` (KeyValue b _) = a `compare` b

instance Functor (KeyValue k) where
  fmap f (KeyValue k v) = KeyValue k (f v)

instance (Monoid k) => Applicative (KeyValue k) where
  pure v = KeyValue mempty v
  (KeyValue k f) <*> (KeyValue k' v) = KeyValue (k `mappend` k') (f v)

type Height = Int

data Tree k v = Leaf | Branch !Height (KeyValue k v) (Tree k v) (Tree k v)
  deriving Show

height :: Tree k v -> Int
height Leaf = 0
height (Branch h _ _ _) = h
{-# INLINABLE height #-}

branch :: KeyValue k v -> Tree k v -> Tree k v -> Tree k v
branch kv a b
  | height a > height b = Branch (1 + height a) kv a b
  | otherwise           = Branch (1 + height b) kv b a
{-# INLINABLE branch #-}

merge :: (Ord k) => Tree k v -> Tree k v -> Tree k v
merge a Leaf = a
merge Leaf b = b
merge a @ (Branch _ kva la ra) b @ (Branch _ kvb lb rb)
  | kva < kvb = branch kva la (merge ra b)
  | otherwise = branch kvb lb (merge a rb)
{-# INLINABLE merge #-}

singleton k v = branch (KeyValue k v) Leaf Leaf
{-# INLINABLE singleton #-}

instance (Ord k) => Monoid (Tree k v) where
  mempty = Leaf
  mappend = merge

instance Functor (Tree k) where
  fmap _ Leaf = Leaf
  fmap f (Branch _ kv a b) = branch (fmap f kv) (fmap f a) (fmap f b)

instance (Monoid k, Ord k) => Applicative (Tree k) where
  pure a = branch (pure a) Leaf Leaf

  Leaf <*> _ = Leaf
  _ <*> Leaf = Leaf
  (Branch _ (KeyValue k f) lfs rfs) <*> t @ (Branch _ kv l r) =
    branch (fmap f kv) (fmap f l) (fmap f r) <> (lfs <*> t) <> (rfs <*> t)

fromList :: (Ord a) => [a] -> Tree a a
fromList = foldl (\t a -> t <> singleton a a) mempty
{-# INLINABLE fromList #-}

toList :: (Ord a) => Tree a a -> [a]
toList Leaf = []
toList (Branch _ (KeyValue k v) a b) = v : (toList (a <> b))
{-# INLINABLE toList #-}

sort :: (Ord a) => [a] -> [a]
sort = toList . fromList
{-# INLINABLE sort #-}