faster-megaparsec 0.1.1.0 → 0.1.2.0
raw patch · 4 files changed
+218/−37 lines, 4 filesdep +bytestringdep +cassavaPVP ok
version bump matches the API change (PVP)
Dependencies added: bytestring, cassava
API changes (from Hackage documentation)
Files
- CHANGELOG.md +8/−0
- faster-megaparsec.cabal +4/−1
- test/Bench.hs +145/−36
- test/GenCsv.hs +61/−0
CHANGELOG.md view
@@ -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.
faster-megaparsec.cabal view
@@ -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
test/Bench.hs view
@@ -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]
+ test/GenCsv.hs view
@@ -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)))