Leftist tree. See: http://programmingpraxis.com/2009/05/05/priority-queues/

pp_leftist_tree.hs

import Data.Function (on)

data Leftist a = Empty | Node {_rank :: Int, val :: a, lch, rch :: (Leftist a)}

rank :: Leftist a -> Int
rank (Node r _ _ _) = r
rank _ = 0

singleton :: a -> Leftist a
singleton a = Node 1 a Empty Empty

merge :: (a -> a -> Bool) -> Leftist a -> Leftist a -> Leftist a
merge _ a Empty = a
merge _ Empty b = b
merge p a b = Node (1 + rank l') (val a') l' r' where
    (a', b') = if on p val b a then (b, a) else (a, b)
    (l, r)   = (lch a', merge p (rch a') b')
    (l', r') = if on (<) rank r l then (r, l) else (l, r)

insert :: (a -> a -> Bool) -> a -> Leftist a -> Leftist a
insert p = merge p . singleton

pop :: (a -> a -> Bool) -> Leftist a -> Maybe (a, Leftist a)
pop p (Node _ a l r) = Just (a, merge p l r)
pop _ _ = Nothing

fromList :: (a -> a -> Bool) -> [a] -> Leftist a
fromList p = mergeAll . map singleton where
    pairs (a:b:xs) = merge p a b: pairs xs
    pairs x = x
    mergeAll []  = Empty
    mergeAll [x] = x
    mergeAll x   = mergeAll (pairs x)

pqSort :: (a -> a -> Bool) -> [a] -> [a]
pqSort p = toList p . fromList p
   
toList :: (a -> a -> Bool) -> Leftist a -> [a]
toList _ Empty          = []
toList p (Node _ i l r) = i : toList p (merge p l r)

main = print $ pqSort (<) [3, 7, 8, 1, 432, 2, 9, 6, 4, 5, 5454, 1, 78678, 54]