faster-megaparsec-0.1.1.0: test/Bench.hs

{-- Benchmarks.
We re-use the 'Language' generator of thr test suite 
and compare how long 'SimpleParser' and 'Parsec' take 
to parse all words of a language, 
which is written to a file before parsing, 
to ensure that both parsers start from an equally-evaluated input. 
--}
{-# LANGUAGE OverloadedStrings, RankNTypes, FlexibleContexts, TypeApplications #-}
import GenLanguage
import qualified Test.QuickCheck as Q
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.IO as TIO
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Void (Void)
import Text.Megaparsec (MonadParsec(..),runParser,sepBy,single)
import Text.Megaparsec.Simple 
import Test.Tasty.Bench (Benchmark,bench,bgroup,bcompare,envWithCleanup,nfIO,defaultMain)
import System.Directory (removeFile)
import System.IO.Temp (emptySystemTempFile)
import Control.DeepSeq (NFData(..))


-- * hard-coded test benchmark parameters 

-- | size parameters passed to the language generator 'randomLanguages' 
useLangSizes :: [Int]
useLangSizes = three `mtimes` (10:[100,120..200]) where
    mtimes :: Monad m => m () -> m a -> m a
    mtimes scalar m = m >>= (\a -> fmap (const a) scalar)
    three = [(),(),()] -- generate three languages of each size

-- * benchmark

writeAllWords :: FilePath -> Language (Set Text) -> IO ()
writeAllWords file = TIO.writeFile file . 
    foldl1 (\txt w -> txt <> "\n" <> w) .
    allWords

-- | read the file written by 'writeAllWords' 
-- and parse using the 'wordsParser', 
-- printing the parsed words to stdout.
-- 
-- @
-- parseAllWordsWith (runParser @Void)
-- parseAllWordsWith simpleParse
-- @
parseAllWordsWith :: (MonadParsec Void Text p) => 
    (forall a. p a -> String -> Text -> result a) -> 
    Language x -> 
    FilePath -> IO (result [Text])
parseAllWordsWith runP lang testFile = fmap 
    (runP (wordsParser lang) testFile) 
    (TIO.readFile testFile)

-- | we keep this paremetric so that 
-- we don't have to mention the megaparsec error type 
-- which changed through library versions. 
ignoreParsecError :: Either err [Text] -> [Text]
ignoreParsecError = either (const []) id

ignoreNothing :: Maybe [Text] -> [Text]
ignoreNothing = maybe [] id

-- | generate a parser for words separated by newline characters
wordsParser :: MonadParsec Void Text p => Language x -> p [Text]
wordsParser lang = let langWord = genParser lang in (langWord `sepBy` single '\n') <* eof

simpleParse :: SimpleParser Text a -> String -> Text -> Maybe a
simpleParse p _ s = fmap  fst (runSimpleParser p s)

data ParserBenchmark = ParserBenchmark {
    parseFromFile :: FilePath,
    runOrdinary :: IO [Text],
    runSimple   :: IO [Text]
    }
instance NFData ParserBenchmark where
    rnf = rnf . parseFromFile -- ^ 'envWithCleanup' requires its type parameter to be member of 'NFData' bot IO actions do not have a normal form. It is enough if the 'testFile' is written. 

-- | 'writeAllWords' and return two actions that parse the same test file, 
-- to be compared in the benchmark.
genBenchmarkable :: Language (Set Text) -> IO ParserBenchmark
genBenchmarkable lang = do
    testFile <- emptySystemTempFile "parserBenchmark.txt"
    writeAllWords testFile lang
    return $ ParserBenchmark
        testFile
        (fmap ignoreParsecError (parseAllWordsWith (runParser @Void) lang testFile)) 
        (fmap ignoreNothing     (parseAllWordsWith simpleParse       lang testFile))

langDepth :: Language x -> Int
langDepth (Word _) = 0
langDepth (Choice _ x y) = 1 + max (langDepth x) (langDepth y)
langDepth (Concat _ x y) = 1 + langDepth x + langDepth y

benchName :: Language (Set Text) -> String
benchName lang = let ws = allWords lang in 
    "language of depth " <> show (langDepth lang) <> 
        " and size " <> show (Set.size ws) <> 
        " e.g. " <> T.unpack (Set.findMin ws)

genBenchmark :: Language (Set Text) -> Benchmark
genBenchmark lang = envWithCleanup setUp cleanUp genBench where
    setUp = genBenchmarkable lang
    cleanUp = removeFile . parseFromFile
    genBench :: ParserBenchmark -> Benchmark
    genBench pb = bgroup (benchName lang) [
        bench    "Parsec"                       (nfIO (runOrdinary pb)),
        bcompare "Parsec" (bench "SimpleParser" (nfIO (runSimple   pb)))
        ]

-- | Generate as many 'Language's as integers given,
-- where the integer is the size parameter passed to QuickCheck's 
-- 'Q.Gen'erator. 
randomLanguages :: [Int] -> IO [Language (Set Text)]
randomLanguages sizes = Q.generate (traverse (flip Q.resize Q.arbitrary) sizes)

genBenchmarks :: IO Benchmark
genBenchmarks = do
    langs <- randomLanguages useLangSizes 
    return (bgroup "parser comparison" (fmap genBenchmark langs))

main :: IO ()
main = genBenchmarks >>= (defaultMain.pure)