alignment-0.2.0.0: bench/Main.hs

{-# LANGUAGE ScopedTypeVariables #-}
{- HLINT ignore "Avoid NonEmpty.unzip" -}

module Main where

import Criterion.Main
import Data.Alignment
import qualified Data.Vector as V
import Data.List.NonEmpty (NonEmpty(..))
import Control.DeepSeq (NFData, force)
import Data.Bifunctor (bimap)

-- Force evaluation to prevent benchmark cheating
forceThis :: (NFData (f (a, b)), NFData (g a), NFData (g b)) => This f g a b -> This f g a b
forceThis (This pairs leftover) = This (force pairs) (force leftover)

-- Benchmark groups
main :: IO ()
main = defaultMain
  [ alignBenchmarks
  , unalignBenchmarks
  , roundtripBenchmarks
  , transformationBenchmarks
  , fusionBenchmarks
  ]

-- | Benchmark align vs zip for different sizes and structures
alignBenchmarks :: Benchmark
alignBenchmarks = bgroup "align vs zip"
  [ bgroup "lists"
      [ bgroup "equal length"
          [ bench "zip 100" $ nf (uncurry zip) (listPair 100)
          , bench "align 100" $ nf (uncurry alignList) (listPair 100)
          , bench "zip 1000" $ nf (uncurry zip) (listPair 1000)
          , bench "align 1000" $ nf (uncurry alignList) (listPair 1000)
          , bench "zip 10000" $ nf (uncurry zip) (listPair 10000)
          , bench "align 10000" $ nf (uncurry alignList) (listPair 10000)
          ]
      , bgroup "unequal length"
          [ bench "zip 100/50" $ nf (\(xs, ys) -> zip xs (take 50 ys)) (listPair 100)
          , bench "align 100/50" $ nf (\(xs, ys) -> alignList xs (take 50 ys)) (listPair 100)
          , bench "zip 1000/500" $ nf (\(xs, ys) -> zip xs (take 500 ys)) (listPair 1000)
          , bench "align 1000/500" $ nf (\(xs, ys) -> alignList xs (take 500 ys)) (listPair 1000)
          ]
      ]
  , bgroup "vectors"
      [ bgroup "equal length"
          [ bench "zip 100" $ nf (uncurry V.zip) (vectorPair 100)
          , bench "align 100" $ nf (uncurry alignVec) (vectorPair 100)
          , bench "zip 1000" $ nf (uncurry V.zip) (vectorPair 1000)
          , bench "align 1000" $ nf (uncurry alignVec) (vectorPair 1000)
          , bench "zip 10000" $ nf (uncurry V.zip) (vectorPair 10000)
          , bench "align 10000" $ nf (uncurry alignVec) (vectorPair 10000)
          ]
      ]
  , bgroup "NonEmpty"
      [ bench "align 100" $ nf (uncurry alignNE) (nePair 100)
      , bench "align 1000" $ nf (uncurry alignNE) (nePair 1000)
      ]
  ]
  where
    alignList :: [Int] -> [Int] -> This [] NonEmpty Int Int
    alignList = align
    alignVec :: V.Vector Int -> V.Vector Int -> This V.Vector NonEmpty Int Int
    alignVec = align
    alignNE :: NonEmpty Int -> NonEmpty Int -> This NonEmpty NonEmpty Int Int
    alignNE = align

-- | Benchmark unalign vs unzip
unalignBenchmarks :: Benchmark
unalignBenchmarks = bgroup "unalign vs unzip"
  [ bgroup "lists"
      [ bench "unzip 100" $ nf unzip (pairList 100)
      , bench "unalign 100" $ nf unalignList (alignedList 100)
      , bench "unzip 1000" $ nf unzip (pairList 1000)
      , bench "unalign 1000" $ nf unalignList (alignedList 1000)
      , bench "unzip 10000" $ nf unzip (pairList 10000)
      , bench "unalign 10000" $ nf unalignList (alignedList 10000)
      ]
  , bgroup "vectors"
      [ bench "unzip 100" $ nf V.unzip (V.fromList $ pairList 100)
      , bench "unalign 100" $ nf unalignVec (alignedVector 100)
      , bench "unzip 1000" $ nf V.unzip (V.fromList $ pairList 1000)
      , bench "unalign 1000" $ nf unalignVec (alignedVector 1000)
      , bench "unzip 10000" $ nf V.unzip (V.fromList $ pairList 10000)
      , bench "unalign 10000" $ nf unalignVec (alignedVector 10000)
      ]
  ]
  where
    unalignList :: This [] NonEmpty Int Int -> ([Int], [Int])
    unalignList = unalign
    unalignVec :: This V.Vector NonEmpty Int Int -> (V.Vector Int, V.Vector Int)
    unalignVec = unalign

-- | Benchmark roundtrip: align then unalign
roundtripBenchmarks :: Benchmark
roundtripBenchmarks = bgroup "roundtrip"
  [ bgroup "lists"
      [ bench "zip/unzip 100" $ nf (\(xs, ys) -> unzip (zip xs ys)) (listPair 100)
      , bench "align/unalign 100" $ nf (\(xs, ys) -> unalign (align xs ys :: This [] NonEmpty Int Int)) (listPair 100)
      , bench "zip/unzip 1000" $ nf (\(xs, ys) -> unzip (zip xs ys)) (listPair 1000)
      , bench "align/unalign 1000" $ nf (\(xs, ys) -> unalign (align xs ys :: This [] NonEmpty Int Int)) (listPair 1000)
      ]
  , bgroup "vectors"
      [ bench "zip/unzip 100" $ nf (\(xs, ys) -> V.unzip (V.zip xs ys)) (vectorPair 100)
      , bench "align/unalign 100" $ nf (\(xs, ys) -> unalign (align xs ys :: This V.Vector NonEmpty Int Int)) (vectorPair 100)
      , bench "zip/unzip 1000" $ nf (\(xs, ys) -> V.unzip (V.zip xs ys)) (vectorPair 1000)
      , bench "align/unalign 1000" $ nf (\(xs, ys) -> unalign (align xs ys :: This V.Vector NonEmpty Int Int)) (vectorPair 1000)
      ]
  ]

-- | Benchmark transformation operations (map during align/unalign)
transformationBenchmarks :: Benchmark
transformationBenchmarks = bgroup "with transformation"
  [ bgroup "lists"
      [ bench "map/zip/map 1000" $ nf (\(xs, ys) -> let zs = zip xs ys in (map ((+1) . fst) zs, map ((*2) . snd) zs)) (listPair 1000)
      , bench "alignWith 1000" $ nf (\(xs, ys) -> alignWith id (+1) (*2) xs ys :: This [] NonEmpty Int Int) (listPair 1000)
      , bench "unzip/map/map 1000" $ nf (bimap (map (+1)) (map (*2)) . unzip) (pairList 1000)
      , bench "unalignWith 1000" $ nf (unalignWith (+1) (*2)) (alignedList 1000)
      ]
  ]

-- | Benchmark fusion effectiveness
fusionBenchmarks :: Benchmark
fusionBenchmarks = bgroup "fusion"
  [ bgroup "composition"
      -- These benchmarks intentionally compare unoptimized vs optimized forms
      {- HLINT ignore "Functor law" -}
      {- HLINT ignore "Redundant bimap" -}
      [ bench "fmap . fmap 1000" $ nf (fmap (*2) . fmap (+1)) (alignedList 1000)
      , bench "fmap composed 1000" $ nf (fmap ((*2) . (+1))) (alignedList 1000)
      , bench "bimap . bimap 1000" $ nf (bimap (*2) (*3) . bimap (+1) (+2)) (alignedList 1000)
      , bench "bimap composed 1000" $ nf (bimap ((*2) . (+1)) ((*3) . (+2))) (alignedList 1000)
      ]
  , bgroup "roundtrip elimination"
      [ bench "align/unalign 1000" $ nf (\(xs, ys) -> unalign (align xs ys :: This [] NonEmpty Int Int)) (listPair 1000)
      , bench "direct 1000" $ nf id (listPair 1000)
      , bench "alignWith/unalignWith 1000" $ nf (\(xs, ys) -> unalignWith (+1) (*2) (align xs ys :: This [] NonEmpty Int Int)) (listPair 1000)
      , bench "map/map 1000" $ nf (bimap (map (+1)) (map (*2))) (listPair 1000)
      ]
  ]

-- Test data generators
listPair :: Int -> ([Int], [Int])
listPair n = ([1..n], [1..n])

vectorPair :: Int -> (V.Vector Int, V.Vector Int)
vectorPair n = (V.enumFromN 1 n, V.enumFromN 1 n)

nePair :: Int -> (NonEmpty Int, NonEmpty Int)
nePair n = (1 :| [2..n], 1 :| [2..n])

pairList :: Int -> [(Int, Int)]
pairList n = [(i, i) | i <- [1..n]]

alignedList :: Int -> This [] NonEmpty Int Int
alignedList n = align [1..n] [1..n]

alignedVector :: Int -> This V.Vector NonEmpty Int Int
alignedVector n = align (V.enumFromN 1 n) (V.enumFromN 1 n)