Natural Sort Algorithm

NaturalSort.hs

import Data.Char (isDigit)
import Data.List (sortBy)

naturalCompare :: String -> String -> Ordering
naturalCompare s@(c:s') t@(d:t')
  | isDigit c && isDigit d = numericCompare 0 s t
  | otherwise = compare c d <> naturalCompare s' t'
naturalCompare s t = compare s t

numericCompare :: Int -> String -> String -> Ordering
numericCompare zCount ('0':s) t = numericCompare (zCount + 1) s t
numericCompare zCount s ('0':t) = numericCompare (zCount - 1) s t
numericCompare zCount s t = numericCompareNoZeros (compare zCount 0) EQ s t

numericCompareNoZeros :: Ordering -> Ordering -> String -> String -> Ordering
numericCompareNoZeros zOrder cOrder s@(c:s') t@(d:t') =
  case (isDigit c, isDigit d) of
    (True, True) -> numericCompareNoZeros zOrder (cOrder <> compare c d) s' t'
    (a, b) -> compare a b <> cOrder <> naturalCompare s t <> zOrder
numericCompareNoZeros zOrder cOrder (c:_) "" = compare (isDigit c) False <> cOrder <> GT
numericCompareNoZeros zOrder cOrder "" (d:_) = compare False (isDigit d) <> cOrder <> LT
numericCompareNoZeros zOrder cOrder "" "" = cOrder <> zOrder

main :: IO ()
main = interact $ unlines . sortBy naturalCompare . lines

NaturalSortText.hs

{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wno-unused-top-binds #-}

import Criterion.Main
import Data.Char (isDigit)
import Data.Text (Text, uncons)
import Data.Vector (Vector)

import qualified Data.Vector as V
import qualified Data.Vector.Algorithms.Intro as Intro
import qualified Data.Text as T
import qualified Data.Text.IO as T

naturalCompare :: Text -> Text -> Ordering
naturalCompare s@(uncons -> Just (c, s')) t@(uncons -> Just (d, t'))
  | isDigit c && isDigit d = numericCompare 0 s t
  | otherwise = compare c d <> naturalCompare s' t'
naturalCompare s t = compare s t
{-# INLINABLE naturalCompare #-}

numericCompare :: Int -> Text -> Text -> Ordering
numericCompare zCount (uncons -> Just ('0', s)) t = numericCompare (zCount + 1) s t
numericCompare zCount s (uncons -> Just ('0', t)) = numericCompare (zCount - 1) s t
numericCompare zCount s t = numericCompareNoZeros (compare zCount 0) EQ s t
{-# INLINABLE numericCompare #-}

numericCompareNoZeros :: Ordering -> Ordering -> Text -> Text -> Ordering
numericCompareNoZeros zOrder cOrder s@(uncons -> Just (c, s')) t@(uncons -> Just (d, t')) =
  case (isDigit c, isDigit d) of
    (True, True) -> numericCompareNoZeros zOrder (cOrder <> compare c d) s' t'
    (a, b) -> compare a b <> cOrder <> naturalCompare s t <> zOrder
numericCompareNoZeros _ cOrder (uncons -> Just (c, _)) _ = compare (isDigit c) False <> cOrder <> GT
numericCompareNoZeros _ cOrder _ (uncons -> Just (d, _)) = compare False (isDigit d) <> cOrder <> LT
numericCompareNoZeros zOrder cOrder _ _ = cOrder <> zOrder
{-# INLINABLE numericCompareNoZeros #-}

fastSortBy :: (Text -> Text -> Ordering) -> Vector Text -> Vector Text
fastSortBy cmp = V.modify (Intro.sortBy cmp)

fastSortByIO :: (Text -> Text -> Ordering) -> Vector Text -> IO (Vector Text)
fastSortByIO cmp v = do
  mv <- V.thaw v
  Intro.sortBy cmp mv
  V.freeze mv

mainBench :: IO ()
mainBench = do
  input <- V.fromList . T.lines <$> T.getContents

  defaultMain
    [ bgroup "Intro"
      [ bench "IO" $
          nfAppIO (fastSortByIO naturalCompare) input
      , bench "ST" $
          nf (fastSortBy naturalCompare) input
      ]
    ]

mainTest :: IO ()
mainTest = T.interact $ T.unlines . V.toList . fastSortBy naturalCompare . V.fromList . T.lines

main :: IO ()
main = mainBench