faster-megaparsec 0.1.0.1 → 0.1.1.0
raw patch · 6 files changed
+313/−135 lines, 6 filesdep +deepseqdep +directorydep +tasty-benchdep ~megaparsecPVP ok
version bump matches the API change (PVP)
Dependencies added: deepseq, directory, tasty-bench, temporary
Dependency ranges changed: megaparsec
API changes (from Hackage documentation)
Files
- CHANGELOG.md +7/−6
- faster-megaparsec.cabal +24/−1
- src/Text/Megaparsec/Simple.hs +11/−1
- test/Bench.hs +125/−0
- test/GenLanguage.hs +142/−0
- test/Spec.hs +4/−127
CHANGELOG.md view
@@ -1,11 +1,12 @@ # Changelog for `faster-megaparsec` -All notable changes to this project will be documented in this file.+## 0.1.0.1 -The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/),-and this project adheres to the-[Haskell Package Versioning Policy](https://pvp.haskell.org/).+Test suite comparing `SimpleParser` against `Parsec`. -## Unreleased+# 0.1.1 -## 0.1.0.0 - YYYY-MM-DD+Changed the definition of `takeP_` to honour the spec+(fail if the input stream is shorter than requested). ++Re-factored the test suite to include a benchmark.
faster-megaparsec.cabal view
@@ -1,6 +1,6 @@ cabal-version: 1.12 name: faster-megaparsec-version: 0.1.0.1+version: 0.1.1.0 description: see README.md homepage: https://hub.darcs.net/olf/faster-megaparsec bug-reports: https://hub.darcs.net/olf/faster-megaparsec/issues@@ -39,6 +39,7 @@ main-is: Spec.hs other-modules: Paths_faster_megaparsec+ GenLanguage 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 -rtsopts -with-rtsopts=-N@@ -49,4 +50,26 @@ , faster-megaparsec , text , QuickCheck+ default-language: Haskell2010++benchmark faster-megaparsec-benchmark+ type: exitcode-stdio-1.0+ main-is: Bench.hs+ other-modules:+ Paths_faster_megaparsec+ GenLanguage+ 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+ , containers >= 0.5.11+ , directory+ , megaparsec+ , faster-megaparsec+ , text+ , QuickCheck+ , tasty-bench+ , deepseq+ , temporary default-language: Haskell2010
src/Text/Megaparsec/Simple.hs view
@@ -141,8 +141,18 @@ -- Since 'Mega.takeP' requests this parser to succeed only if -- the requested number of tokens can be returned, and we can never -- return a negative number of tokens, this parser fails for negative inputs. +-- This behaviour changes in Megaparsec with version 9.3.0+#if MIN_VERSION_megaparsec(9,3,0) countAny :: forall s. (Mega.Stream s) => Int -> StateT s Maybe (Mega.Tokens s)-countAny n = if n < 0 then mzero else StateT (\s -> Mega.takeN_ n s)+countAny n = StateT (\s -> + Mega.takeN_ n s >>= + (\x@(taken,_) -> if Mega.chunkLength (Proxy :: Proxy s) taken < n then Nothing else Just x))+#else+countAny :: forall s. (Mega.Stream s) => Int -> StateT s Maybe (Mega.Tokens s)+countAny n = if n < 0 then mzero else StateT (\s -> + Mega.takeN_ n s >>= + (\x@(taken,_) -> if Mega.chunkLength (Proxy :: Proxy s) taken < n then Nothing else Just x))+#endif {-# INLINE countAny #-} -- | (For the 'MonadParsec' instance) 'Parser' does not contain any state besides the input left to parse.
+ test/Bench.hs view
@@ -0,0 +1,125 @@+{-- Benchmarks.+We re-use the 'Language' generator of thr test suite +and compare how long 'SimpleParser' and 'Parsec' take +to parse all words of a language, +which is written to a file before parsing, +to ensure that both parsers start from an equally-evaluated input. +--}+{-# LANGUAGE OverloadedStrings, RankNTypes, FlexibleContexts, TypeApplications #-}+import GenLanguage+import qualified Test.QuickCheck as Q+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.IO as TIO+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Void (Void)+import Text.Megaparsec (MonadParsec(..),runParser,sepBy,single)+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(..))+++-- * hard-coded test benchmark parameters ++-- | size parameters passed to the language generator 'randomLanguages' +useLangSizes :: [Int]+useLangSizes = three `mtimes` (10:[100,120..200]) where+ mtimes :: Monad m => m () -> m a -> m a+ mtimes scalar m = m >>= (\a -> fmap (const a) scalar)+ three = [(),(),()] -- generate three languages of each size++-- * benchmark++writeAllWords :: FilePath -> Language (Set Text) -> IO ()+writeAllWords file = TIO.writeFile file . + foldl1 (\txt w -> txt <> "\n" <> w) .+ allWords++-- | read the file written by 'writeAllWords' +-- and parse using the 'wordsParser', +-- printing the parsed words to stdout.+-- +-- @+-- parseAllWordsWith (runParser @Void)+-- parseAllWordsWith simpleParse+-- @+parseAllWordsWith :: (MonadParsec Void Text p) => + (forall a. p a -> String -> Text -> result a) -> + Language x -> + FilePath -> IO (result [Text])+parseAllWordsWith runP lang testFile = fmap + (runP (wordsParser lang) testFile) + (TIO.readFile testFile)++-- | 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 (const []) id++ignoreNothing :: Maybe [Text] -> [Text]+ignoreNothing = maybe [] id++-- | generate a parser for words separated by newline characters+wordsParser :: MonadParsec Void Text p => Language x -> p [Text]+wordsParser lang = let langWord = genParser lang in (langWord `sepBy` single '\n') <* eof++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)+langDepth (Concat _ x y) = 1 + langDepth x + langDepth y++benchName :: Language (Set Text) -> String+benchName lang = let ws = allWords lang in + "language of depth " <> show (langDepth lang) <> + " 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)++genBenchmarks :: IO Benchmark+genBenchmarks = do+ langs <- randomLanguages useLangSizes + return (bgroup "parser comparison" (fmap genBenchmark langs))++main :: IO ()+main = genBenchmarks >>= (defaultMain.pure)
+ test/GenLanguage.hs view
@@ -0,0 +1,142 @@+{-# LANGUAGE FlexibleInstances,FlexibleContexts,DeriveGeneric,DeriveFunctor #-}+module GenLanguage where+import Data.String (IsString(..))+import Data.Text (Text)+import qualified Data.Text as T+import Data.List (transpose)+import Control.Applicative (liftA2)+import GHC.Generics (Generic)+import Test.QuickCheck (Arbitrary(..))+import qualified Test.QuickCheck as Q+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Void (Void)+import Text.Megaparsec++-- * Generating random languages to parse++-- ** Languages++-- | The language is designed to test the basic +-- parser operations concatenation and choice. +data Language x = Word String+ | Choice x (Language x) (Language x)+ | Concat x (Language x) (Language x)+ deriving (Show,Eq,Ord,Generic,Functor)++instance IsString (Language x) where+ fromString = Word+instance Semigroup (Language ()) where+ (<>) = Concat ()+instance Semigroup (Language (Set Text)) where+ (Word w1) <> (Word w2) = Word (w1<>w2)+ x@(Word w) <> y@(Choice ws _ _) = let pfx = fromString w + in Concat (Set.mapMonotonic (pfx<>) ws) x y+ x@(Word w) <> y@(Concat ws _ _) = let pfx = fromString w+ in Concat (Set.mapMonotonic (pfx<>) ws) x y+ x <> y = let ws = Set.map (uncurry (<>)) (Set.cartesianProduct (allWords x) (allWords y))+ in Concat ws x y++class Monad m => NonDeterministic m where+ nonDeterministically :: [m a] -> m a+instance NonDeterministic [] where+ nonDeterministically = concat . transpose -- can enumerate finite choice of infinite lists+instance NonDeterministic Q.Gen where+ nonDeterministically = Q.oneof++class Conditionable m where+ suchThat :: m a -> (a -> Bool) -> m a+instance Conditionable [] where+ suchThat = flip filter+instance Conditionable Q.Gen where + suchThat = Q.suchThat+instance Conditionable Set where+ suchThat = flip Set.filter+++infixl 3 <||>+-- | The choice operator of 'Language's+(<||>) :: Language (Set Text) -> Language (Set Text) -> Language (Set Text)+x <||> y = Choice (choiceWords (allWords x) (allWords y)) x y++-- |Even with backtracking, +-- a parser may fail to recognize a word of the language +-- if the choices are ordered in a way such that +-- an earlier choice contains a proper prefix of a later choice. +-- Consider for example the regular expression+-- +-- @+-- (a|ab)c+-- @+--+-- and the word @abc@ which is not accepted by the parser +-- +-- @+-- (try (chunk "a") <|> chunk "ab") <> chunk "c"+-- @+-- +-- but is accepted by the parser +-- +-- @+-- (try (chunk "ab") <|> chunk "a") <> chunk "c"+-- @+choiceWords :: Set Text -> Set Text -> Set Text+choiceWords left right = Set.union left (right `suchThat` notSuffixOf left) where+ notSuffixOf earlier = \w -> not (any (\a -> a `T.isPrefixOf` w) earlier)++-- | 'nonDeterministically' sample from 'allWords' of a 'Language'.+genWords :: NonDeterministic gen => + Language (Set Text) -> gen Text+genWords = nonDeterministically . fmap pure . Set.toList . allWords++-- | We record the set of words in the constructor.+allWords :: Language (Set Text) -> Set Text+allWords (Word w) = Set.singleton (fromString w)+allWords (Choice ws _ _) = ws+allWords (Concat ws _ _) = ws++-- ** parsing a language++-- | generate a 'MonadParsec' parser for words of the given 'Language'+genParser :: MonadParsec Void Text p => Language x -> p Text+genParser (Word txt) = chunk (fromString txt)+genParser (Choice _ x y) = try (genParser x) <|> genParser y -- backtracking choice+genParser (Concat _ x y) = liftA2 (<>) (genParser x) (genParser y)++-- ** non-deterministic language generation++-- non-deterministically generate a language+-- +-- >>> mapM_ print $ fmap (const ()) $ genLanguage ["Foo","Bar"] 1+-- >>> Q.sample' (arbitrary :: Q.Gen (Language (Set Text))) >>= (print.fmap (const ()).head) +genLanguage :: NonDeterministic gen => + gen String -> + Int -> + gen (Language (Set Text))+genLanguage genWord = let + sizedLang = \size -> if size <= 0 then fmap Word genWord else let+ lang' = sizedLang (size `div` 2)+ in nonDeterministically [+ fmap Word genWord,+ liftA2 (<>) lang' lang',+ liftA2 (<||>) lang' lang'+ ]+ in sizedLang++-- | We make single-letter alphanumeric words the basic building blocks of languages+genAlphaChar :: NonDeterministic gen => gen Char+genAlphaChar = nonDeterministically [return c | c <- ['a'..'z']]++genWordQ :: Q.Gen String+genWordQ = fmap pure genAlphaChar -- use single-letter words as building blocks+-- genWordQ = let g = genAlphaChar in liftA2 (:) (fmap toUpper g) (Q.listOf g)++instance Arbitrary (Language (Set Text)) where+ arbitrary = Q.sized (genLanguage genWordQ)+ shrink (Word _) = []+ shrink (Concat _ lang1 lang2) = [lang1,lang2] ++ [x <> y | (x,y) <- shrink (lang1,lang2)]+ shrink (Choice _ lang1 lang2) = [lang1,lang2] ++ [x <||> y | (x,y) <- shrink (lang1,lang2)]++-- maximum word length+maxWord :: Language (Set Text) -> Int+maxWord = Set.foldl' (\imum w -> max imum (T.length w)) 0 . allWords
test/Spec.hs view
@@ -22,11 +22,10 @@ FlexibleInstances, TypeFamilies, OverloadedStrings, - DeriveGeneric, - DeriveFunctor, RankNTypes, ScopedTypeVariables #-}+import GenLanguage -- randomly generate languages to parse import Text.Megaparsec import Text.Megaparsec.Simple import Data.Void (Void)@@ -34,13 +33,10 @@ import Data.Text (Text) import qualified Data.Text as T import Data.Maybe (isJust)-import Data.List (transpose) import Control.Applicative (liftA2)-import GHC.Generics (Generic) import Test.QuickCheck (Arbitrary(..)) import qualified Test.QuickCheck as Q import Data.Set (Set)-import qualified Data.Set as Set main :: IO () main = do@@ -59,130 +55,11 @@ putStrLn "testing whether takeP behaves identically" Q.quickCheck prop_takeP +-- | Parser selector. 'Ordinary' selects 'Parsec', +-- 'Fast' selects 'SimpleParser'. data WhichParser = Fast | Ordinary --- * Parsing languages---- | The language is designed to test the basic --- parser operations concatenation and choice. -data Language x = Word String- | Choice x (Language x) (Language x)- | Concat x (Language x) (Language x)- deriving (Show,Eq,Ord,Generic,Functor)--instance IsString (Language x) where- fromString = Word-instance Semigroup (Language ()) where- (<>) = Concat ()-instance Semigroup (Language (Set Text)) where- (Word w1) <> (Word w2) = Word (w1<>w2)- x@(Word w) <> y@(Choice ws _ _) = let pfx = fromString w - in Concat (Set.mapMonotonic (pfx<>) ws) x y- x@(Word w) <> y@(Concat ws _ _) = let pfx = fromString w- in Concat (Set.mapMonotonic (pfx<>) ws) x y- x <> y = let ws = Set.map (uncurry (<>)) (Set.cartesianProduct (allWords x) (allWords y))- in Concat ws x y--class Monad m => NonDeterministic m where- nonDeterministically :: [m a] -> m a-instance NonDeterministic [] where- nonDeterministically = concat . transpose -- can enumerate finite choice of infinite lists-instance NonDeterministic Q.Gen where- nonDeterministically = Q.oneof--class Conditionable m where- suchThat :: m a -> (a -> Bool) -> m a-instance Conditionable [] where- suchThat = flip filter-instance Conditionable Q.Gen where - suchThat = Q.suchThat-instance Conditionable Set where- suchThat = flip Set.filter---infixl 3 <||>--- | The choice operator of 'Language's-(<||>) :: Language (Set Text) -> Language (Set Text) -> Language (Set Text)-x <||> y = Choice (choiceWords (allWords x) (allWords y)) x y---- |Even with backtracking, --- a parser may fail to recognize a word of the language --- if the choices are ordered in a way such that --- an earlier choice contains a proper prefix of a later choice. --- Consider for example the regular expression--- --- @--- (a|ab)c--- @------ and the word @abc@ which is not accepted by the parser --- --- @--- (try (chunk "a") <|> chunk "ab") <> chunk "c"--- @--- --- but is accepted by the parser --- --- @--- (try (chunk "ab") <|> chunk "a") <> chunk "c"--- @-choiceWords :: Set Text -> Set Text -> Set Text-choiceWords left right = Set.union left (right `suchThat` notSuffixOf left) where- notSuffixOf earlier = \w -> not (any (\a -> a `T.isPrefixOf` w) earlier)--genWords :: NonDeterministic gen => - Language (Set Text) -> gen Text-genWords = nonDeterministically . fmap pure . Set.toList . allWords---- | We record the set of words in the constructor.-allWords :: Language (Set Text) -> Set Text-allWords (Word w) = Set.singleton (fromString w)-allWords (Choice ws _ _) = ws-allWords (Concat ws _ _) = ws---- ** non-deterministic language generation---- non-deterministically generate a language--- --- >>> mapM_ print $ fmap (const ()) $ genLanguage ["Foo","Bar"] 1--- >>> Q.sample' (arbitrary :: Q.Gen (Language (Set Text))) >>= (print.fmap (const ()).head) -genLanguage :: NonDeterministic gen => - gen String -> - Int -> - gen (Language (Set Text))-genLanguage genWord = let - sizedLang = \size -> if size <= 0 then fmap Word genWord else let- lang' = sizedLang (size `div` 2)- in nonDeterministically [- fmap Word genWord,- liftA2 (<>) lang' lang',- liftA2 (<||>) lang' lang'- ]- in sizedLang--genAlphaChar :: NonDeterministic gen => gen Char-genAlphaChar = nonDeterministically [return c | c <- ['a'..'z']]--genWordQ :: Q.Gen String-genWordQ = fmap pure genAlphaChar -- use single-letter words as building blocks--- genWordQ = let g = genAlphaChar in liftA2 (:) (fmap toUpper g) (Q.listOf g)--instance Arbitrary (Language (Set Text)) where- arbitrary = Q.sized (genLanguage genWordQ)- shrink (Word _) = []- shrink (Concat _ lang1 lang2) = [lang1,lang2] ++ [x <> y | (x,y) <- shrink (lang1,lang2)]- shrink (Choice _ lang1 lang2) = [lang1,lang2] ++ [x <||> y | (x,y) <- shrink (lang1,lang2)]---- maximum word length-maxWord :: Language (Set Text) -> Int-maxWord = Set.foldl' (\imum w -> max imum (T.length w)) 0 . allWords---- ** checking the behaviour of parsers--genParser :: MonadParsec Void Text p => Language x -> p Text-genParser (Word txt) = chunk (fromString txt)-genParser (Choice _ x y) = try (genParser x) <|> genParser y -- backtracking choice-genParser (Concat _ x y) = liftA2 (<>) (genParser x) (genParser y)+-- * checking the behaviour of parsers -- Tests whether 'genParser' accepts all words generated by 'genWords'. -- This can take loooong if the language is large.