diff options
Diffstat (limited to 'benchmark/benchmark-pandoc.hs')
| -rw-r--r-- | benchmark/benchmark-pandoc.hs | 83 |
1 files changed, 43 insertions, 40 deletions
diff --git a/benchmark/benchmark-pandoc.hs b/benchmark/benchmark-pandoc.hs index 4d5c67c43..c19b5e80e 100644 --- a/benchmark/benchmark-pandoc.hs +++ b/benchmark/benchmark-pandoc.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TupleSections #-} {- Copyright (C) 2012-2017 John MacFarlane <jgm@berkeley.edu> @@ -17,67 +18,69 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -} import Text.Pandoc import qualified Text.Pandoc.UTF8 as UTF8 -import Data.Text (Text) -import Data.Time (getCurrentTime) import qualified Data.ByteString as B import Criterion.Main import Criterion.Types (Config(..)) +import Data.List (intersect) import Data.Maybe (mapMaybe) -import Debug.Trace (trace) import System.Environment (getArgs) readerBench :: Pandoc - -> (String, ReaderOptions -> Text -> Pandoc) + -> String -> Maybe Benchmark -readerBench doc (name, reader) = - case lookup name writers of - Just (TextWriter writer) -> - let inp = either (error . show) id $ runPure - $ writer def{ writerWrapText = WrapAuto} doc - in return $ bench (name ++ " reader") $ nf - (reader def) inp - _ -> Debug.Trace.trace - ("\nCould not find writer for " ++ name ++ "\n") Nothing +readerBench doc name = + case res of + Right (readerFun, inp) -> + Just $ bench (name ++ " reader") + $ nf (\i -> either (error . show) id $ runPure (readerFun i)) + inp + Left _ -> Nothing + where res = runPure $ do + (TextReader r, rexts) + <- either (fail . show) return $ getReader name + (TextWriter w, wexts) + <- either (fail . show) return $ getWriter name + inp <- w def{ writerWrapText = WrapAuto, writerExtensions = wexts } + doc + return (r def{ readerExtensions = rexts }, inp) writerBench :: Pandoc - -> (String, WriterOptions -> Pandoc -> Text) - -> Benchmark -writerBench doc (name, writer) = bench (name ++ " writer") $ nf - (writer def{ writerWrapText = WrapAuto }) doc + -> String + -> Maybe Benchmark +writerBench doc name = + case res of + Right writerFun -> + Just $ bench (name ++ " writer") + $ nf (\d -> either (error . show) id $ + runPure (writerFun d)) doc + _ -> Nothing + where res = runPure $ do + (TextWriter w, wexts) + <- either (fail . show) return $ getWriter name + return $ w def{ writerExtensions = wexts } main :: IO () main = do - args <- getArgs + args <- filter (\x -> take 1 x /= "-") <$> getArgs print args let matchReader (n, TextReader _) = - "reader" `elem` args && n `elem` args + null args || ("reader" `elem` args && n `elem` args) matchReader _ = False let matchWriter (n, TextWriter _) = - "writer" `elem` args && n `elem` args + null args || ("writer" `elem` args && n `elem` args) matchWriter _ = False - let matchedReaders = filter matchReader readers - let matchedWriters = filter matchWriter writers + let matchedReaders = map fst $ (filter matchReader readers + :: [(String, Reader PandocPure)]) + let matchedWriters = map fst $ (filter matchWriter writers + :: [(String, Writer PandocPure)]) inp <- UTF8.toText <$> B.readFile "test/testsuite.txt" - lalune <- B.readFile "test/lalune.jpg" - movie <- B.readFile "test/movie.jpg" - time <- Data.Time.getCurrentTime - let setupFakeFiles = modifyPureState $ \st -> st{ stFiles = - insertInFileTree "lalune.jpg" - (FileInfo time lalune) $ - insertInFileTree "movie.jpg" - (FileInfo time movie) mempty - } let opts = def let doc = either (error . show) id $ runPure $ readMarkdown opts inp - let readers' = [(n, \o d -> - either (error . show) id $ runPure $ r o d) - | (n, TextReader r) <- matchedReaders] let readerBs = mapMaybe (readerBench doc) - $ filter (\(n,_) -> n /="haddock") readers' - let writers' = [(n, \o d -> - either (error . show) id $ runPure $ setupFakeFiles >> w o d) - | (n, TextWriter w) <- matchedWriters] - let writerBs = map (writerBench doc) - $ writers' + $ filter (/="haddock") + (matchedReaders `intersect` matchedWriters) + -- we need the corresponding writer to generate + -- input for the reader + let writerBs = mapMaybe (writerBench doc) matchedWriters defaultMainWith defaultConfig{ timeLimit = 6.0 } (writerBs ++ readerBs) |