diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -10,3 +10,11 @@ (fail if the input stream is shorter than requested). Re-factored the test suite to include a benchmark. + +# 0.1.2 + +Included a benchmark for CSV parsing. +Speedup on 100000 lines is roughly +0.7x against ParsecT and +0.6x against Cassava +when decoding only few columns of a broad table. diff --git a/faster-megaparsec.cabal b/faster-megaparsec.cabal --- a/faster-megaparsec.cabal +++ b/faster-megaparsec.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 name: faster-megaparsec -version: 0.1.1.0 +version: 0.1.2.0 description: see README.md homepage: https://hub.darcs.net/olf/faster-megaparsec bug-reports: https://hub.darcs.net/olf/faster-megaparsec/issues @@ -58,15 +58,18 @@ other-modules: Paths_faster_megaparsec GenLanguage + GenCsv hs-source-dirs: test ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded build-depends: base >=4.7 && <5 + , bytestring , containers >= 0.5.11 , directory , megaparsec , faster-megaparsec + , cassava , text , QuickCheck , tasty-bench diff --git a/test/Bench.hs b/test/Bench.hs --- a/test/Bench.hs +++ b/test/Bench.hs @@ -7,6 +7,7 @@ --} {-# LANGUAGE OverloadedStrings, RankNTypes, FlexibleContexts, TypeApplications #-} import GenLanguage +import GenCsv import qualified Test.QuickCheck as Q import Data.Text (Text) import qualified Data.Text as T @@ -14,13 +15,17 @@ import Data.Set (Set) import qualified Data.Set as Set import Data.Void (Void) -import Text.Megaparsec (MonadParsec(..),runParser,sepBy,single) +import qualified Data.Csv as Cassava +import qualified Data.ByteString.Lazy as B +import qualified Data.Foldable as Fold +import Text.Megaparsec +import Text.Megaparsec.Char.Lexer (decimal,signed) 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(..)) - +import Control.Monad (mzero) -- * hard-coded test benchmark parameters @@ -31,8 +36,36 @@ mtimes scalar m = m >>= (\a -> fmap (const a) scalar) three = [(),(),()] -- generate three languages of each size --- * benchmark +-- | number of rows in randomly generated CSV file +csvNumRows :: Int +csvNumRows = 100000 :: Int +-- | number of randomly generated CSV tabke structures +csvNumStructures :: Int +csvNumStructures = 5 + +-- * parser benchmark type + +data ParserBenchmark a = ParserBenchmark { + parseFromFile :: FilePath, + withParsec :: IO [a], + withSimpleParse :: IO [a], + withCassava :: IO [a] + } +instance NFData (ParserBenchmark a) 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. + +genBenchmark :: NFData b => (a -> String) -> (a -> IO (ParserBenchmark b)) -> a -> Benchmark +genBenchmark name toBenchmark a = envWithCleanup setUp cleanUp genBench where + setUp = toBenchmark a + cleanUp = removeFile . parseFromFile + genBench pb = bgroup (name a) [ + (bench "Parsec" (nfIO (withParsec pb))), + (bcompare "Parsec" (bench "SimpleParser" (nfIO (withSimpleParse pb)))), + (bcompare "Parsec" (bench "Cassava" (nfIO (withCassava pb))))] + +-- * benchmark language parsers + writeAllWords :: FilePath -> Language (Set Text) -> IO () writeAllWords file = TIO.writeFile file . foldl1 (\txt w -> txt <> "\n" <> w) . @@ -57,10 +90,10 @@ -- | 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 err [a] -> [a] ignoreParsecError = either (const []) id -ignoreNothing :: Maybe [Text] -> [Text] +ignoreNothing :: Maybe [a] -> [a] ignoreNothing = maybe [] id -- | generate a parser for words separated by newline characters @@ -70,25 +103,6 @@ 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) @@ -100,26 +114,121 @@ " 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) +-- | 'writeAllWords' and return two actions that parse the same test file, +-- to be compared in the benchmark. +genBenchmarkable :: Language (Set Text) -> IO (ParserBenchmark Text) +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)) + (fmap (const []) (return ())) + genBenchmarks :: IO Benchmark genBenchmarks = do langs <- randomLanguages useLangSizes - return (bgroup "parser comparison" (fmap genBenchmark langs)) + return (bgroup "language parser comparison (cassava not applicable here)" (fmap (genBenchmark benchName genBenchmarkable) langs)) + +-- * benchmark CSV parsers + +data Comma = LeadingComma | TrailingComma + +-- | skip over uninteresting fields +skipFields :: MonadParsec Void Text p => Int -> Comma -> p () +skipFields n comma = if n <= 0 + then return () + else () <$ (count n skipField) where + co = case comma of + TrailingComma -> (\p -> p <* single ',') + LeadingComma -> (\p -> single ',' *> p) + skipField = co (takeWhileP (Just "some csv field") (\c -> c /= ',' && c /= '\n')) + +parsecBool :: MonadParsec Void Text p => p Bool +parsecBool = (True <$ chunk "True") <|> (False <$ chunk "False") + +-- | The 'CSVStructure' dictates that in column 'fooCol' an integer +-- and in column 'barCol' a boolean is to be found. +parsecCSVrow :: MonadParsec Void Text p => CSVStructure -> p (Int,Bool) +parsecCSVrow c = do + _ <- skipFields (fooCol c) TrailingComma + i <- signed (return ()) decimal <* single ',' + _ <- skipFields (barCol c - fooCol c - 1) TrailingComma + b <- parsecBool + _ <- skipFields (tableWidth c - 1 - barCol c) LeadingComma + return (i,b) + +-- | We extract and decode two columns from a CSV file of up two 50 columns +parsecCSV :: MonadParsec Void Text p => CSVStructure -> p [(Int,Bool)] +parsecCSV c = takeWhileP (Just "header line") ('\n' /=) *> single '\n' *> + (parsecCSVrow c `sepEndBy` single '\n') <* eof + +-- analogous to 'parseAllWordsWith' +parseCsvWith :: (MonadParsec Void Text p) => + (forall a. p a -> String -> Text -> result a) -> + CSVStructure -> + FilePath -> IO (result [(Int,Bool)]) +parseCsvWith runP struct testFile = fmap + (runP (parsecCSV struct) testFile) + (TIO.readFile testFile) + +csvBenchName :: CSVStructure -> String +csvBenchName c = "CSV file with " <> show (tableWidth c) <> " columns " <> + "and Int in column " <> show (fooCol c) <> + " and Bool in column " <> show (barCol c) + +newtype LitBool = LitBool Bool +instance NFData LitBool where + rnf (LitBool b) = rnf b +instance Cassava.FromField LitBool where + parseField s + | s == "True" = pure (LitBool True) + | s == "False" = pure (LitBool False) + | otherwise = mzero + +data IntBool = IntBool !Int !LitBool +instance NFData IntBool where + rnf (IntBool i b) = rnf (i,b) +instance Cassava.FromNamedRecord IntBool where + parseNamedRecord r = IntBool <$> r Cassava..: "foo" <*> r Cassava..: "bar" +fromIntBool :: IntBool -> (Int,Bool) +fromIntBool (IntBool i (LitBool b)) = (i,b) + +-- decode using cassava. +cassavaIntBool :: FilePath -> IO [(Int,Bool)] +cassavaIntBool testFile = fmap dec (B.readFile testFile) where + dec = either (const []) (Fold.toList . fmap fromIntBool .snd) . Cassava.decodeByName + +-- analogous to 'genBenchmarkable' +csvBenchmarkable :: CSVStructure -> IO (ParserBenchmark (Int,Bool)) +csvBenchmarkable c = do + content <- Q.generate (genCSVFile c csvNumRows) + testFile <- emptySystemTempFile "parserBenchmark.csv" + TIO.writeFile testFile content + return $ ParserBenchmark + testFile + (fmap ignoreParsecError (parseCsvWith (runParser @Void) c testFile)) + (fmap ignoreNothing (parseCsvWith simpleParse c testFile)) + ( cassavaIntBool testFile) + +genCsvBenchmarks :: IO Benchmark +genCsvBenchmarks = do + structures <- Q.generate (sequence (replicate csvNumStructures genCSVStructure)) + return (bgroup "csv parser comparison" (fmap (genBenchmark csvBenchName csvBenchmarkable) structures)) + + +-- * main + main :: IO () -main = genBenchmarks >>= (defaultMain.pure) +main = do + bench1 <- genBenchmarks + bench2 <- genCsvBenchmarks + defaultMain [bench1,bench2] diff --git a/test/GenCsv.hs b/test/GenCsv.hs new file mode 100644 --- /dev/null +++ b/test/GenCsv.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE OverloadedStrings #-} +module GenCsv (CSVStructure(..),genCSVStructure,genCSVFile) where +import qualified Test.QuickCheck as Q +import Data.Text (Text) +import qualified Data.Text as T +import GenLanguage (genAlphaChar) + + +genTextField :: Q.Gen Text +genTextField = fmap T.pack (Q.listOf genAlphaChar) + +genNumField :: Q.Gen Text +genNumField = fmap (T.pack . (show :: Int -> String)) Q.arbitrary + +genBoolField :: Q.Gen Text +genBoolField = fmap (T.pack . (show :: Bool -> String)) Q.arbitrary + +data CSVStructure = CSVStructure { + tableWidth :: Int, + fooCol :: Int, -- ^ an 'Int' column + barCol :: Int, -- ^ a 'Bool' column + columnTitles :: [Text] -- we include a title row so that we can test against cassava's NamedRecord decoding + } + +csvHeader :: CSVStructure -> Text +csvHeader = T.intercalate "," . columnTitles + +-- | generate a CSV file structure: +-- two columns named @foo@ and @bar@ +-- at random positions in a table of random width. +genCSVStructure :: Q.Gen CSVStructure +genCSVStructure = do + width <- Q.chooseInt (5,50) + foo <- Q.chooseInt (0,width-2) + bar <- Q.chooseInt (foo+1,width-1) + beforeFoo <- sequence (replicate foo genTextField) + betweenFooBar <- sequence (replicate (bar-foo-1) genTextField) + afterBar <- sequence (replicate (width-1-bar) genTextField) + return $ CSVStructure { + tableWidth = width, + fooCol = foo, + barCol = bar, + columnTitles = beforeFoo <> ["foo"] <> betweenFooBar <> ["bar"] <> afterBar + } + +-- | generate a row of given structure +genCSVrow :: CSVStructure -> Q.Gen Text +genCSVrow c = (fmap (T.intercalate ",") . sequence) ( + (replicate (fooCol c) genTextField) ++ + [genNumField] ++ + (replicate (barCol c - fooCol c - 1) genTextField) ++ + [genBoolField] ++ + (replicate (tableWidth c - 1 - barCol c) genTextField) + ) + +-- | generate a csv table of given structure +-- and number of data rows +genCSVFile :: CSVStructure -> Int -> Q.Gen Text +genCSVFile c rows = fmap + (T.unlines . ((csvHeader c):)) + (sequence (replicate rows (genCSVrow c)))