module MergeSort (
  msortBy
 ) where

infixl 7 :%
infixr 6 :&

data LenList a = LL {-# UNPACK #-} !Int Bool [a]

data LenListAnd a b = {-# UNPACK #-} !(LenList a) :% b

data Stack a
  = End
  | {-# UNPACK #-} !(LenList a) :& (Stack a)

msortBy :: (a -> a -> Ordering) -> [a] -> [a]
msortBy cmp = mergeSplit End where
  splitAsc n _ _ _ | n `seq` False = undefined
  splitAsc n as _ [] = LL n True as :% []
  splitAsc n as a bs@(b:bs') = case cmp a b of
    GT -> LL n False as :% bs
    _  -> splitAsc (n + 1) as b bs'

  splitDesc n _ _ _ | n `seq` False = undefined
  splitDesc n rs a [] = LL n True (a:rs) :% []
  splitDesc n rs a bs@(b:bs') = case cmp a b of
    GT -> splitDesc (n + 1) (a:rs) b bs'
    _  -> LL n True (a:rs) :% bs

  mergeLL (LL na fa as) (LL nb fb bs) = LL (na + nb) True $ mergeLs na as nb bs where
    mergeLs nx  _ ny  _ | nx `seq` ny `seq` False = undefined
    mergeLs  0  _ ny ys = if fb then ys else take ny ys
    mergeLs  _ [] ny ys = if fb then ys else take ny ys
    mergeLs nx xs  0  _ = if fa then xs else take nx xs
    mergeLs nx xs  _ [] = if fa then xs else take nx xs
    mergeLs nx xs@(x:xs') ny ys@(y:ys') = case cmp x y of
      GT -> y:mergeLs nx xs (ny - 1) ys'
      _  -> x:mergeLs (nx - 1) xs' ny ys

  push ssx px@(LL nx _ _) = case ssx of
    End -> px :% ssx
    py@(LL ny _ _) :& ssy -> case ssy of
      End
        | nx >= ny -> mergeLL py px :% ssy
      pz@(LL nz _ _) :& ssz
        | nx >= ny || nx + ny >= nz -> case nx > nz of
            False -> push ssy $ mergeLL py px
            _     -> case push ssz $ mergeLL pz py of
              pz' :% ssz' -> push (pz' :& ssz') px
      _ -> px :% ssx

  mergeAll _ px | px `seq` False = undefined
  mergeAll ssx px@(LL nx _ xs) = case ssx of
    End -> xs
    py@(LL _ _ _) :& ssy -> case ssy of
      End -> case mergeLL py px of
        LL _ _ xys -> xys
      pz@(LL nz _ _) :& ssz -> case nx > nz of
        False -> mergeAll ssy $ mergeLL py px
        _     -> case push ssz $ mergeLL pz py of
          pz' :% ssz' -> mergeAll (pz' :& ssz') px

  mergeSplit ss _ | ss `seq` False = undefined
  mergeSplit ss [] = case ss of
    End -> []
    px :& ss' -> mergeAll ss' px
  mergeSplit ss as@(a:as') = case as' of
    [] -> mergeAll ss $ LL 1 True as
    b:bs -> case cmp a b of
      GT -> case splitDesc 2 [a] b bs of
        px :% rs -> case push ss px of
          px' :% ss' -> mergeSplit (px' :& ss') rs
      _  -> case splitAsc 2 as b bs of
        px :% rs -> case push ss px of
          px' :% ss' -> mergeSplit (px' :& ss') rs
  {-# INLINABLE mergeSplit #-}