text_append_bench.hs

{-# OPTIONS -O2 -Wall #-}

module Main (main) where

import Criterion.Main
import Data.Text (Text)
import qualified Data.Text              as Text

-- This benchmark demonstrates the non-linear performance of
-- appending text. The behavior I would expect would be that
-- stream fusion would cause appending twenty characters to
-- take four times as long as appending five characters. However,
-- this is not the case.

main :: IO ()
main = defaultMain
  [ bgroup "Text Append Fusion"
    [ bench "Five Chars" $ whnf fiveChars 'x'
    , bench "Ten Chars" $ whnf tenChars 'x'
    , bench "Ten Chars (left-associated append)" $ whnf tenCharsAssociateLeft 'x'
    , bench "Twenty Chars" $ whnf twentyChars 'x'
    , bench "Twenty Chars (left-associated append)" $ whnf twentyCharsAssociateLeft 'x'
    ]
  ]

fiveChars :: Char -> Text
fiveChars =
    mappend (Text.singleton 'a')
  . mappend (Text.singleton 'b')
  . mappend (Text.singleton 'c')
  . mappend (Text.singleton 'd')
  . Text.singleton

tenChars :: Char -> Text
tenChars =
    mappend (Text.singleton 'a')
  . mappend (Text.singleton 'b')
  . mappend (Text.singleton 'c')
  . mappend (Text.singleton 'd')
  . mappend (Text.singleton 'e')
  . mappend (Text.singleton 'f')
  . mappend (Text.singleton 'g')
  . mappend (Text.singleton 'h')
  . mappend (Text.singleton 'i')
  . Text.singleton

tenCharsAssociateLeft :: Char -> Text
tenCharsAssociateLeft a = (Text.singleton 'a')
  `mappend` (Text.singleton 'b')
  `mappend` (Text.singleton 'c')
  `mappend` (Text.singleton 'd')
  `mappend` (Text.singleton 'e')
  `mappend` (Text.singleton 'f')
  `mappend` (Text.singleton 'g')
  `mappend` (Text.singleton 'h')
  `mappend` (Text.singleton 'i')
  `mappend` (Text.singleton a)

twentyChars :: Char -> Text
twentyChars =
    mappend (Text.singleton 'a')
  . mappend (Text.singleton 'b')
  . mappend (Text.singleton 'c')
  . mappend (Text.singleton 'd')
  . mappend (Text.singleton 'e')
  . mappend (Text.singleton 'f')
  . mappend (Text.singleton 'g')
  . mappend (Text.singleton 'h')
  . mappend (Text.singleton 'i')
  . mappend (Text.singleton 'j')
  . mappend (Text.singleton 'k')
  . mappend (Text.singleton 'l')
  . mappend (Text.singleton 'm')
  . mappend (Text.singleton 'n')
  . mappend (Text.singleton 'o')
  . mappend (Text.singleton 'p')
  . mappend (Text.singleton 'q')
  . mappend (Text.singleton 'r')
  . mappend (Text.singleton 's')
  . Text.singleton

twentyCharsAssociateLeft :: Char -> Text
twentyCharsAssociateLeft a = (Text.singleton 'a')
  `mappend` (Text.singleton 'b')
  `mappend` (Text.singleton 'c')
  `mappend` (Text.singleton 'd')
  `mappend` (Text.singleton 'e')
  `mappend` (Text.singleton 'f')
  `mappend` (Text.singleton 'g')
  `mappend` (Text.singleton 'h')
  `mappend` (Text.singleton 'i')
  `mappend` (Text.singleton 'b')
  `mappend` (Text.singleton 'c')
  `mappend` (Text.singleton 'd')
  `mappend` (Text.singleton 'e')
  `mappend` (Text.singleton 'f')
  `mappend` (Text.singleton 'g')
  `mappend` (Text.singleton 'h')
  `mappend` (Text.singleton 'i')
  `mappend` (Text.singleton 'h')
  `mappend` (Text.singleton 'i')
  `mappend` (Text.singleton a)