aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--benchmark/benchmark-pandoc.hs83
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)