diff options
| -rw-r--r-- | Makefile | 5 | ||||
| -rw-r--r-- | benchmark/benchmark-pandoc.hs | 111 |
2 files changed, 41 insertions, 75 deletions
@@ -2,11 +2,10 @@ version?=$(shell grep '^[Vv]ersion:' pandoc.cabal | awk '{print $$2;}') pandoc=$(shell find dist -name pandoc -type f -exec ls -t {} \; | head -1) SOURCEFILES?=$(shell git ls-tree -r master --name-only | grep "\.hs$$") BRANCH?=master -RESOLVER?=lts-13 GHCOPTS=-fdiagnostics-color=always WEBSITE=../../web/pandoc.org REVISION?=1 -BENCHARGS?="--timeout=6 +RTS -T -RTS" +BENCHARGS?=--timeout=6 +RTS -T -RTS $(if $(PATTERN),--pattern "$(PATTERN)",) quick: stack install --ghc-options='$(GHCOPTS)' --install-ghc --flag 'pandoc:embed_data_files' --fast --test --ghc-options='-j +RTS -A64m -RTS' --test-arguments='-j4 --hide-successes $(TESTARGS)' @@ -39,7 +38,7 @@ ghcid: ghcid -c "stack repl --flag 'pandoc:embed_data_files'" bench: - stack bench --benchmark-arguments=$(BENCHARGS) --ghc-options '$(GHCOPTS)' + stack bench --benchmark-arguments='$(BENCHARGS)' --ghc-options '$(GHCOPTS)' weigh: stack build --ghc-options '$(GHCOPTS)' pandoc:weigh-pandoc && stack exec weigh-pandoc diff --git a/benchmark/benchmark-pandoc.hs b/benchmark/benchmark-pandoc.hs index 496732693..96810a477 100644 --- a/benchmark/benchmark-pandoc.hs +++ b/benchmark/benchmark-pandoc.hs @@ -18,48 +18,37 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -} import Text.Pandoc import Text.Pandoc.MIME -import Control.Monad.Except (throwError, liftIO) +import Control.Monad.Except (throwError) import qualified Text.Pandoc.UTF8 as UTF8 import qualified Data.ByteString as B import qualified Data.Text as T import Test.Tasty.Bench -import Data.List (intersect) -import Data.Maybe (mapMaybe, catMaybes) -import System.Environment (getArgs) import qualified Data.ByteString.Lazy as BL - -data Input = InputText {unInputText :: T.Text} - | InputBS {unInputBS :: BL.ByteString} +import Data.Maybe (mapMaybe) readerBench :: Pandoc -> T.Text - -> IO (Maybe Benchmark) -readerBench doc name = do - let (rdr, rexts) = either (error . show) id . runPure $ getReader name - res <- runIO $ do - (wtr, wexts) <- getWriter name - case (rdr, wtr) of - (TextReader r, TextWriter w) -> do - setResourcePath ["./test"] - inp <- w def{ writerWrapText = WrapAuto - , writerExtensions = wexts } doc - return (r def{ readerExtensions = rexts } . unInputText, InputText inp) - (ByteStringReader r, ByteStringWriter w) -> do - setResourcePath ["./test"] - tmpl <- Just <$> compileDefaultTemplate name - inp <- w def{ writerWrapText = WrapAuto - , writerExtensions = wexts - , writerTemplate = tmpl } doc - liftIO $ BL.writeFile "/tmp/test.odt" inp - return (r def{ readerExtensions = rexts } . unInputBS, InputBS inp) - _ -> throwError $ PandocSomeError $ "text/bytestring format mismatch: " - <> name - return $ case res of - Right (readerFun, inp) -> - Just $ bench (T.unpack name) - $ nf (\i -> either (error . show) id $ runPure (readerFun i)) - inp - Left _ -> Nothing + -> Maybe Benchmark +readerBench doc name = either (const Nothing) Just $ + runPure $ do + (rdr, rexts) <- getReader name + (wtr, wexts) <- getWriter name + case (rdr, wtr) of + (TextReader r, TextWriter w) -> do + inp <- w def{ writerWrapText = WrapAuto + , writerExtensions = wexts } doc + return $ bench (T.unpack name) $ + nf (either (error . show) id . runPure . r def) inp + (ByteStringReader r, ByteStringWriter w) -> do + tmpl <- Just <$> compileDefaultTemplate name + inp <- w def{ writerWrapText = WrapAuto + , writerExtensions = wexts + , writerTemplate = tmpl } doc + return $ bench (T.unpack name) $ + nf (either (error . show) id . + runPure . r def{readerExtensions = rexts}) inp + _ -> throwError $ PandocSomeError $ "text/bytestring format mismatch: " + <> name getImages :: IO [(FilePath, MimeType, BL.ByteString)] getImages = do @@ -72,51 +61,29 @@ writerBench :: [(FilePath, MimeType, BL.ByteString)] -> Pandoc -> T.Text -> Maybe Benchmark -writerBench imgs doc name = - case res of - Right writerFun -> - Just $ bench (T.unpack name) +writerBench imgs doc name = either (const Nothing) Just $ + runPure $ do + (wtr, wexts) <- getWriter name + case wtr of + TextWriter writerFun -> + return $ bench (T.unpack name) $ nf (\d -> either (error . show) id $ - runPure (do mapM_ - (\(fp, mt, bs) -> - insertMedia fp (Just mt) bs) - imgs - writerFun d)) doc - Left _ -> Nothing - where res = runPure $ do - (wtr, wexts) <- getWriter name - case wtr of - TextWriter w -> - return $ w def{ writerExtensions = wexts } - _ -> throwError $ PandocSomeError - $ "could not get text writer for " <> name + runPure $ do + mapM_ (\(fp,mt,bs) -> insertMedia fp (Just mt) bs) imgs + writerFun def{ writerExtensions = wexts} d) + doc + _ -> throwError $ PandocSomeError + $ "could not get text writer for " <> name main :: IO () main = do - args <- filter (\x -> T.take 1 x /= "-") . fmap T.pack <$> getArgs - print args - let matchReader (n, _) = - null args || ("reader" `elem` args && n `elem` args) - matchWriter (n, TextWriter _) = - null args || ("writer" `elem` args && n `elem` args) - matchWriter _ = False - allWriters = map fst (writers :: [(T.Text, Writer PandocPure)]) - matchedReaders = map fst (filter matchReader readers - :: [(T.Text, Reader PandocPure)]) - matchedWriters = map fst (filter matchWriter writers - :: [(T.Text, Writer PandocPure)]) inp <- UTF8.toText <$> B.readFile "test/testsuite.txt" let opts = def let doc = either (error . show) id $ runPure $ readMarkdown opts inp - readerBs <- fmap catMaybes - $ mapM (readerBench doc) - $ filter (/="haddock") - (matchedReaders `intersect` allWriters) - -- we need the corresponding writer to generate - -- input for the reader imgs <- getImages - let writerBs = mapMaybe (writerBench imgs doc) matchedWriters defaultMain - [ bgroup "writers" writerBs - , bgroup "readers" readerBs + [ bgroup "writers" $ mapMaybe (writerBench imgs doc . fst) + (writers :: [(T.Text, Writer PandocPure)]) + , bgroup "readers" $ mapMaybe (readerBench doc . fst) + (readers :: [(T.Text, Reader PandocPure)]) ] |