Merge.hs

{-# OPTIONS_GHC -Wno-deprecations #-}

-- |
-- Module      : Main
-- Copyright   : (c) 2018 Composewell Technologies
--
-- License     : BSD3
-- Maintainer  : streamly@composewell.com

{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RankNTypes #-}

#ifdef __HADDOCK_VERSION__
#undef INSPECTION
#endif

#ifdef INSPECTION
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -fplugin Test.Inspection.Plugin #-}
#endif

import Streamly.Internal.Data.Stream.IsStream (SerialT)
import qualified Data.List as List
import qualified Streamly.Internal.Data.Stream.IsStream as Stream
-- import qualified Streamly.Internal.Data.Unfold as Unfold

import Streamly.Benchmark.Common
import Streamly.Benchmark.Prelude

import Test.Tasty.Bench

#ifdef INSPECTION
import GHC.Types (SPEC(..))
import Test.Inspection

import qualified Streamly.Internal.Data.Stream as D
#endif

moduleName :: String
moduleName = "Prelude.Merge"

-------------------------------------------------------------------------------
-- Merging
-------------------------------------------------------------------------------

{-# INLINE mergeWith #-}
mergeWith ::
    (  (Int -> Int -> Ordering)
    -> SerialT IO Int
    -> SerialT IO Int
    -> SerialT IO Int
    )
    -> (Int -> Int -> Ordering)
    -> Int -> Int -> IO ()
mergeWith g cmp count n =
    Stream.drain
        $ g
            cmp
            (sourceUnfoldrM count n)
            (sourceUnfoldrM count (n + 1))

{-# INLINE mergeWithM #-}
mergeWithM ::
    (  (Int -> Int -> IO Ordering)
    -> SerialT IO Int
    -> SerialT IO Int
    -> SerialT IO Int
    )
    -> (Int -> Int -> Ordering)
    -> Int -> Int -> IO ()
mergeWithM g cmp count n =
    Stream.drain
        $ g
            (\a b -> return $ cmp a b)
            (sourceUnfoldrM count n)
            (sourceUnfoldrM count (n + 1))

{-# INLINE mergeBy #-}
mergeBy :: (Int -> Int -> Ordering) -> Int -> Int -> IO ()
mergeBy = mergeWith Stream.mergeBy

{-# INLINE mergeByM #-}
mergeByM :: (Int -> Int -> Ordering) -> Int -> Int -> IO ()
mergeByM = mergeWithM Stream.mergeByM

{-# INLINE mergeByMFused #-}
mergeByMFused :: (Int -> Int -> Ordering) -> Int -> Int -> IO ()
mergeByMFused = mergeWithM Stream.mergeByMFused

#ifdef INSPECTION
inspect $ hasNoTypeClasses 'mergeBy
inspect $ 'mergeBy `hasNoType` ''SPEC
inspect $ 'mergeBy `hasNoType` ''D.Step

inspect $ hasNoTypeClasses 'mergeByM
inspect $ 'mergeByM `hasNoType` ''SPEC
inspect $ 'mergeByM `hasNoType` ''D.Step

{-# INLINE _mergeByMFusedCheck #-}
_mergeByMFusedCheck :: IO ()
_mergeByMFusedCheck = mergeWithM Stream.mergeByMFused compare 0 0

inspect $ hasNoTypeClasses '_mergeByMFusedCheck
inspect $ '_mergeByMFusedCheck `hasNoType` ''SPEC
inspect $ '_mergeByMFusedCheck `hasNoType` ''D.Step
#endif

{-# INLINE concatPairsWithMergeBy #-}
concatPairsWithMergeBy :: (Int -> Int -> Ordering) -> Int -> Int -> Int -> IO ()
concatPairsWithMergeBy cmp = concatPairsWith (Stream.mergeBy cmp)

{-# INLINE concatPairsWithMergeByFused #-}
concatPairsWithMergeByFused ::
    (Int -> Int -> Ordering) -> Int -> Int -> Int -> IO ()
concatPairsWithMergeByFused cmp =
    concatPairsWith (Stream.mergeByMFused (\x y -> return $ cmp x y))

-------------------------------------------------------------------------------
-- Interleaving
-------------------------------------------------------------------------------

o_1_space_joining :: Int -> [Benchmark]
o_1_space_joining value =
    [ bgroup "joining (2 of n/2)"
        [ benchIOSrc1
            "mergeBy compare"
            (mergeBy compare (value `div` 2))
        , benchIOSrc1
            "mergeByM compare"
            (mergeByM compare (value `div` 2))
        , benchIOSrc1
            "mergeByMFused compare"
            (mergeByMFused compare (value `div` 2))

        , benchIOSrc1
            "mergeBy (flip compare)"
            (mergeBy (flip compare) (value `div` 2))
        , benchIOSrc1
            "mergeByM (flip compare)"
            (mergeByM (flip compare) (value `div` 2))
        , benchIOSrc1
            "mergeByMFused (flip compare)"
            (mergeByMFused (flip compare) (value `div` 2))

        , benchIOSrc1
            "concatPairsWithMergeBy compare"
            (concatPairsWithMergeBy compare 2 (value `div` 2))
        , benchIOSrc1
            "concatPairsWithMergeBy (flip compare)"
            (concatPairsWithMergeBy (flip compare) 2 (value `div` 2))

        , benchIOSrc1
            "concatPairsWithMergeByFused compare"
            (concatPairsWithMergeByFused compare 2 (value `div` 2))
        , benchIOSrc1
            "concatPairsWithMergeByFused (flip compare)"
            (concatPairsWithMergeByFused (flip compare) 2 (value `div` 2))
        ]
    ]

-------------------------------------------------------------------------------
-- Concat
-------------------------------------------------------------------------------

{-
{-# INLINE sourceUnfoldrMUF #-}
-- (count, value)
sourceUnfoldrMUF :: Monad m => Int -> UF.Unfold m (Int, Int) Int
sourceUnfoldrMUF count = UF.unfoldrM step
    where
    step (cnt, start) =
        return $
            if cnt > start + count
            then Nothing
            else Just (cnt, (cnt + 1, start))

{-# INLINE unfoldManyMergeBy #-}
unfoldManyMergeBy :: Int -> Int -> Int -> IO ()
unfoldManyMergeBy outer inner n =
    S.drain $ (Internal.unfoldManyMergeBy compare)
        -- (UF.lmap return (UF.replicateM inner))
        (UF.lmap (\x -> (x,x)) (sourceUnfoldrMUF inner))
        (sourceUnfoldrM outer n)

#ifdef INSPECTION
inspect $ hasNoTypeClasses 'unfoldManyMergeBy
-- inspect $ 'unfoldManyMergeBy `hasNoType` ''SPEC
-- inspect $ 'unfoldManyMergeBy `hasNoType`
--      ''D.ConcatUnfoldMergeState
#endif
-}

{-# INLINE sortBy #-}
sortBy :: (Int -> Int -> Ordering) -> SerialT IO Int -> IO ()
sortBy cmp = Stream.drain . Stream.sortBy cmp

{-
-- For fair comparison with concatPairs, removed sorted segmentation
{-# INLINE listSortBy #-}
listSortBy :: (a -> a -> Ordering) -> [a] -> [a]
listSortBy cmp = mergeAll . sequences
  where
    sequences = fmap (: [])

    mergeAll [x] = x
    mergeAll xs  = mergeAll (mergePairs xs)

    mergePairs (a:b:xs) = let !x = merge a b
                          in x : mergePairs xs
    mergePairs xs       = xs

    merge as@(a:as') bs@(b:bs')
      | a `cmp` b == GT = b:merge as  bs'
      | otherwise       = a:merge as' bs
    merge [] bs         = bs
    merge as []         = as
-}

o_n_heap_concat :: Int -> [Benchmark]
o_n_heap_concat value =
    [ bgroup "concatPairsWith"
        [ benchIOSrc1
            "concatPairsWithMergeBy compare (n of 1)"
            (concatPairsWithMergeBy compare value 1)
        , benchIOSrc1
            "concatPairsWithMergeBy compare (sqrtVal of sqrtVal)"
            (concatPairsWithMergeBy compare sqrtVal sqrtVal)

        , benchIOSrc1
            "concatPairsWithMergeBy (flip compare) (n of 1)"
            (concatPairsWithMergeBy (flip compare) value 1)
        , benchIOSrc1
            "concatPairsWithMergeBy (flip compare) (sqrtVal of sqrtVal)"
            (concatPairsWithMergeBy (flip compare) sqrtVal sqrtVal)

        , benchIOSrc1
            "concatPairsWithMergeByFused compare (n of 1)"
            (concatPairsWithMergeByFused compare value 1)
        , benchIOSrc1
            "concatPairsWithMergeByFused compare (sqrtVal of sqrtVal)"
            (concatPairsWithMergeByFused compare sqrtVal sqrtVal)
        ]
    -- TODO: change sourceUnfoldrM to generate alternating bigger and lower
    -- numbers to simulate a random input for a worst case sort benchmark. We
    -- can use 0 and value as two ints in the state and alternate each in the
    -- output streams, incrementing the lower number of decrementing the higher
    -- number.
    , bgroup "sorting"
        [ benchIOSink value "sortBy compare" (sortBy compare)
        , benchIOSink value "sortBy (flip compare)" (sortBy (flip compare))
        , benchIOSink value "sortBy compare randomized"
            (sortBy compare . Stream.map (\x -> if even x then x + 2 else x))
        {-
        , bench "sortByLists compare"
            $ nf (\x -> listSortBy compare [1..x]) value
        , bench "sortByLists (flip compare)"
            $ nf (\x -> listSortBy (flip compare) [1..x]) value
        , bench "sortByLists compare randomized"
            $ nf (\x -> listSortBy compare
                    (map (\n -> if even n then n + 2 else n) [1..x])
                 )
                 value
        -}
        , bench "sortByLists compare"
            $ nf (\x -> List.sortBy compare [1..x]) value
        , bench "sortByLists (flip compare)"
            $ nf (\x -> List.sortBy (flip compare) [1..x]) value
        , bench "sortByLists compare randomized"
            $ nf (\x -> List.sortBy compare
                    (map (\n -> if even n then n + 2 else n) [1..x])
                 )
                 value
        ]
    ]

    where

    sqrtVal = round $ sqrt (fromIntegral value :: Double)

-------------------------------------------------------------------------------
-- Main
-------------------------------------------------------------------------------

-- In addition to gauge options, the number of elements in the stream can be
-- passed using the --stream-size option.
--
main :: IO ()
main = runWithCLIOpts defaultStreamSize allBenchmarks

    where

    allBenchmarks size =
        [ bgroup (o_1_space_prefix moduleName) (o_1_space_joining size)
        , bgroup (o_n_heap_prefix moduleName) (o_n_heap_concat size)
        ]