A duality of sorts

bubbleSort.hs

{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE DeriveFunctor #-}

module Main where

-- Fix point

fix :: ((a -> b) -> (a -> b)) -> (a -> b)
fix f = f (fix f)

newtype Fix f = In { out :: f (Fix f) }

instance Show (f (Fix f)) => Show (Fix f) where
  show (In f) = "(" ++ show f ++ ")"

-- Recursion Schemes

cata :: Functor f => (f a -> a) -> (Fix f -> a) -> (Fix f -> a)
cata psi f = psi . fmap f . out

cataRec :: Functor f => (f a -> a) -> (Fix f -> a)
cataRec psi = fix (cata psi)

ana :: Functor f => (a -> f a) -> (a -> Fix f) -> (a -> Fix f)
ana psi f = In . fmap f . psi

anaRec :: Functor f => (a -> f a) -> (a -> Fix f)
anaRec psi = fix (ana psi)

-- List

data ListF a b = Empty | Cons a b deriving (Functor, Show)

type List a = Fix (ListF a)

fromListAlg :: [a] -> ListF a [a]
fromListAlg [] = Empty
fromListAlg (x:xs) = Cons x xs

fromList :: [a] -> List a
fromList = anaRec fromListAlg

toListAlg :: ListF a [a] -> [a]
toListAlg Empty = []
toListAlg (Cons x xs) = x:xs

toList :: List a -> [a]
toList = cataRec toListAlg

swap :: Ord a => ListF a (ListF a b) -> ListF a (ListF a b)
swap Empty = Empty
swap (Cons a Empty) = Cons a Empty
swap (Cons a (Cons b x))
  | a <= b    = Cons a (Cons b x)
  | otherwise = Cons b (Cons a x)

sortList :: Ord a => List a -> List a
sortList = anaRec (cataRec (fmap In . swap))

sort :: Ord a => [a] -> [a]
sort = toList . sortList . fromList

main :: IO ()
main = print $ sort [1,9,2,8,4,7,5,6,0,3]