diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,11 @@ +# Changelog for `faster-megaparsec` + +All notable changes to this project will be documented in this file. + +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/). + +## Unreleased + +## 0.1.0.0 - YYYY-MM-DD diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,1 @@ +See https://www.gnu.org/licenses/gpl-3.0.txt diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,23 @@ +# faster-megaparsec + +This package defines a MonadParsec instance for +(a type isomorphic to) `StateT s Maybe` +where `s` is a Megaparsec Stream type such as `String`, `Text` or `ByteString`. +This parser can be faster than Cassava for csv parsing +but at the cost of no error information whatsoever. + +If, however, you construct your parser in a generic `MonadParsec` fashion, +then with the help of `Text.Megaparsec.Simple.tryFast` +you can first attempt to specialize and run the fast parser +supplied by this package and only on parse error specialize +the parser to `ParsecT` and parse again, yielding an informative +error message. +This buys you speed in the smooth case of successful parsing +at the cost of double parse when something goes wrong. + +Beware that the behaviour of a `SimpleParser` can differ from its `Parsec` sibling +because + + * `SimpleParser` is always backtracking since it does not know whether it has consumed tokens, + * any fancy parsing that relies on inspecting parser state components such as offset will not work as intended. + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/faster-megaparsec.cabal b/faster-megaparsec.cabal new file mode 100644 --- /dev/null +++ b/faster-megaparsec.cabal @@ -0,0 +1,52 @@ +cabal-version: 1.12 +name: faster-megaparsec +version: 0.1.0.0 +description: Speed up Megaparsec parsing when parsing succeeds +homepage: https://hub.darcs.net/olf/faster-megaparsec +bug-reports: https://hub.darcs.net/olf/faster-megaparsec/issues +author: Olaf Klinke +maintainer: olaf.klinke@phymetric.de, olf@aatal-apotheke.de +copyright: 2022 Lackmann Phymetric GmbH +license: GPL-3 +license-file: LICENSE +build-type: Simple +category: Parsing +synopsis: see README.md +extra-source-files: + README.md + CHANGELOG.md + +source-repository head + type: darcs + location: https://hub.darcs.net/olf/faster-megaparsec + +library + exposed-modules: + Text.Megaparsec.Simple + other-modules: + Paths_faster_megaparsec + hs-source-dirs: + src + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints + build-depends: + base >=4.7 && <5 + , megaparsec >= 6 && <10 + , mtl < 2.4 + default-language: Haskell2010 + +test-suite faster-megaparsec-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_faster_megaparsec + 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 + build-depends: + base >=4.7 && <5 + , containers >= 0.5.11 + , megaparsec + , faster-megaparsec + , text + , QuickCheck + default-language: Haskell2010 diff --git a/src/Text/Megaparsec/Simple.hs b/src/Text/Megaparsec/Simple.hs new file mode 100644 --- /dev/null +++ b/src/Text/Megaparsec/Simple.hs @@ -0,0 +1,292 @@ +{-# LANGUAGE MultiParamTypeClasses + ,FlexibleInstances + ,FlexibleContexts + ,Rank2Types + ,TypeFamilies + ,ScopedTypeVariables + ,DerivingVia + ,CPP #-} +{-| +Module : Text.Megaparsec.Simple +Description : primitive StateT parser with Megaparsec instance +Copyright : (c) Lackmann Phymetric +License : GPL-3 +Maintainer : olaf.klinke@phymetric.de +Stability : experimental + +This module defines a 'MonadParsec' instance for +(a type isomorphic to) @'StateT' s 'Maybe'@ +where @s@ is a Megaparsec 'Mega.Stream' type such as @String@, @Text@ or @ByteString@. +This parser can be faster than Cassava for csv parsing +but at the cost of no error information whatsoever. + +If, however, you construct your parser in a generic 'MonadParsec' fashion, +then with the help of 'tryFast' you can first attempt to specialize and run the fast parser +supplied by this module and only on parse error specialize +the parser to @ParsecT@ and parse again, yielding an informative +error message. +This buys you speed in the smooth case of successful parsing +at the cost of double parse when something goes wrong. + +Beware that the behaviour of a 'SimpleParser' can differ from its 'Mega.Parsec' sibling +because + + * 'SimpleParser' is always backtracking since it does not know whether it has consumed tokens, + * any fancy parsing that relies on inspecting parser state components such as offset will not work as intended. + +-} +module Text.Megaparsec.Simple ( + SimpleParser, + tryFast, + -- * Conversion from/to StateT + toSimpleParser, + runSimpleParser) where +import Control.Monad.State.Strict +import Control.Applicative +import Data.String (IsString(..)) +import Data.Maybe (isNothing) +import Data.Proxy (Proxy(..)) +import Data.Void (Void) +import qualified Text.Megaparsec as Mega +import Text.Megaparsec (MonadParsec,State(..)) + +-- * Parsing + +-- | This parser type is isomorphic to +-- @StateT s Maybe@ +-- but has roughly the same instances as 'Mega.Parsec'. +-- Since it maintains no state besides the unconsumed input, +-- it is considerably faster than 'Mega.Parsec' +-- but can be built using the same combinators. +newtype SimpleParser s a = SimpleParser (StateT s Maybe a) + deriving (Functor,Applicative,Alternative,Monad,MonadPlus,MonadFail) + via (StateT s Maybe) + +instance Semigroup a => Semigroup (SimpleParser s a) where + p <> q = liftA2 (<>) p q +instance Monoid a => Monoid (SimpleParser s a) where + mempty = pure mempty + mappend = (<>) +instance (a ~ Mega.Tokens s, IsString a, Eq a, Mega.Stream s) + => IsString (SimpleParser s a) where + fromString s = Mega.tokens (==) (fromString s) + +-- | The 'Parser' is an ordinary State transformer +-- on Megaparsec streams. +type Parser a = forall s. Mega.Stream s => StateT s Maybe a + +-- | synonym for 'evalStateT' +parse :: SimpleParser s a -> s -> Maybe a +parse (SimpleParser p) = evalStateT p + +-- | Run the 'SimpleParser' on the given input. +-- Consider using 'tryFast' instead if possible. +runSimpleParser :: SimpleParser s a -> s -> Maybe (a,s) +runSimpleParser (SimpleParser p) = runStateT p + +-- | Use this to implement more parser combinators. +toSimpleParser :: StateT s Maybe a -> SimpleParser s a +toSimpleParser = SimpleParser + +-- | The @result@ type of Megaparsec has changed through +-- the library versions +-- (commonly @result = Either err@ for some @err@) +-- whence we abstract over it. +-- Instead of +-- +-- @ +-- 'Mega.runParser' p +-- @ +-- +-- you should use +-- +-- @ +-- 'tryFast' 'Mega.runParser' p +-- @ +-- +-- which tries the fast parser and falls back to 'Mega.Parsec' +-- in case of a parse failure. +tryFast :: forall s a result. (Applicative result, Mega.Stream s) + => (Mega.Parsec Void s a -> String -> s -> result a) -- ^ function to run if fast parsing fails + -> (forall p. (MonadParsec Void s p) => p a) -- ^ a generic parser + -> String -- ^ input stream name + -> s -- ^ input stream + -> result a +tryFast runParser p name s = case parse p s of + Just a -> pure a + Nothing -> runParser p name s + +-- * Combinators + +-- ** String parsing + +-- | parses end of input +eof :: Parser () +eof = StateT (\s -> if isNothing (Mega.take1_ s) then Just ((),s) else Nothing) +{-# INLINE eof #-} + +-- | more efficient than, but equivalent to 'many' . 'satisfy' +takeWhileP :: (Mega.Stream s) => (Mega.Token s -> Bool) -> StateT s Maybe (Mega.Tokens s) +takeWhileP p = StateT (Just . Mega.takeWhile_ p) +{-# INLINE takeWhileP #-} + +-- | more efficient than, but equivalent to 'some' . 'satisfy' +takeWhile1P :: forall s. (Mega.Stream s) => (Mega.Token s -> Bool) -> StateT s Maybe (Mega.Tokens s) +takeWhile1P = mfilter (not. Mega.chunkEmpty (Proxy :: Proxy s)) . takeWhileP +{-# INLINE takeWhile1P #-} + +-- | parse any string of given length, using 'splitAt'. +-- More efficient than @\\n -> 'count' n ('satisfy' ('const' 'True'))@. +-- Fails if input does not have that many characters left. +-- 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. +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) +{-# INLINE countAny #-} + +-- | (For the 'MonadParsec' instance) 'Parser' does not contain any state besides the input left to parse. +#if MIN_VERSION_megaparsec(7,0,0) +#if MIN_VERSION_megaparsec(8,0,0) +dummyState :: s -> Mega.State s e +dummyState s = Mega.State { + stateInput = s, + stateOffset = 0, + statePosState = Mega.PosState { + Mega.pstateInput = s, + Mega.pstateOffset = 0, + Mega.pstateSourcePos = Mega.initialPos "", + Mega.pstateTabWidth = Mega.pos1, + Mega.pstateLinePrefix = "" + }, + stateParseErrors = [] +} +getDummyState :: StateT s Maybe (Mega.State s e) +getDummyState = fmap dummyState get +#else +dummyState :: s -> Mega.State s +dummyState s = Mega.State { + stateInput = s, + stateOffset = 0, + statePosState = Mega.PosState { + Mega.pstateInput = s, + Mega.pstateOffset = 0, + Mega.pstateSourcePos = Mega.initialPos "", + Mega.pstateTabWidth = Mega.pos1, + Mega.pstateLinePrefix = "" + } +} +getDummyState :: StateT s Maybe (Mega.State s) +getDummyState = fmap dummyState get +#endif +#else +dummyState :: s -> Mega.State s +dummyState s = Mega.State { + stateInput = s, + statePos = return (Mega.initialPos "no source info"), + stateTokensProcessed = 0, + stateTabWidth = Mega.pos1 + } +getDummyState :: StateT s Maybe (Mega.State s) +getDummyState = fmap dummyState get +#endif + +-- smart constructor +sStateT :: (s -> Maybe (a,s)) -> SimpleParser s a +sStateT = SimpleParser. StateT + +#if MIN_VERSION_megaparsec(7,0,0) +#if MIN_VERSION_megaparsec(8,0,0) +instance forall s. (Mega.Stream s) => MonadParsec Void s (SimpleParser s) where + parseError _ = sStateT (const Nothing) + label _ = id + hidden = id + try = id + lookAhead p = sStateT (\s -> case parse p s of + Nothing -> Nothing + Just a -> Just (a,s)) + notFollowedBy p = sStateT (\s -> case parse p s of + Nothing -> Just ((),s) + Just _ -> Nothing) + withRecovery handle p = sStateT (\s -> maybe (runSimpleParser (handle mempty) s) Just (runSimpleParser p s)) + observing p = sStateT (\s -> case runSimpleParser p s of + Nothing -> Just (Left mempty,s) + Just (a,s') -> Just (Right a,s')) + eof = SimpleParser eof + token test _ = sStateT (\s -> case Mega.take1_ s of + Nothing -> Nothing + Just (t,s') -> case test t of + Nothing -> Nothing + Just a -> Just (a,s')) + tokens cmp xs = sStateT (\s -> case Mega.takeN_ (Mega.chunkLength (Proxy :: Proxy s) xs) s of + Nothing -> Nothing + Just (ys,s') -> if cmp xs ys then Just (xs,s') else Nothing) + getParserState = SimpleParser getDummyState + updateParserState f = sStateT (\s -> Just ((),(stateInput.f.dummyState) s)) + takeWhileP _ = SimpleParser . takeWhileP + takeWhile1P _ = SimpleParser . takeWhile1P + takeP _ = SimpleParser . countAny +#else +instance forall s. (Mega.Stream s) => MonadParsec Void s (SimpleParser s) where + failure _ _ = sStateT (const Nothing) + fancyFailure _ = sStateT (const Nothing) + label _ = id + hidden = id + try = id + lookAhead p = sStateT (\s -> case parse p s of + Nothing -> Nothing + Just a -> Just (a,s)) + notFollowedBy p = sStateT (\s -> case parse p s of + Nothing -> Just ((),s) + Just _ -> Nothing) + withRecovery handle p = sStateT (\s -> maybe (runSimpleParser (handle mempty) s) Just (runSimpleParser p s)) + observing p = sStateT (\s -> case runSimpleParser p s of + Nothing -> Just (Left mempty,s) + Just (a,s') -> Just (Right a,s')) + eof = SimpleParser eof + token test _ = sStateT (\s -> case Mega.take1_ s of + Nothing -> Nothing + Just (t,s') -> case test t of + Nothing -> Nothing + Just a -> Just (a,s')) + tokens cmp xs = sStateT (\s -> case Mega.takeN_ (Mega.chunkLength (Proxy :: Proxy s) xs) s of + Nothing -> Nothing + Just (ys,s') -> if cmp xs ys then Just (xs,s') else Nothing) + getParserState = SimpleParser getDummyState + updateParserState f = sStateT (\s -> Just ((),(stateInput.f.dummyState) s)) + takeWhileP _ = SimpleParser . takeWhileP + takeWhile1P _ = SimpleParser . takeWhile1P + takeP _ = SimpleParser . countAny +#endif +#else +instance forall s. (Mega.Stream s) => MonadParsec Void s (SimpleParser s) where + failure _ _ = sStateT (const Nothing) + fancyFailure _ = sStateT (const Nothing) + label _ = id + hidden = id + try = id + lookAhead p = sStateT (\s -> case parse p s of + Nothing -> Nothing + Just a -> Just (a,s)) + notFollowedBy p = sStateT (\s -> case parse p s of + Nothing -> Just ((),s) + Just _ -> Nothing) + withRecovery handle p = sStateT (\s -> maybe (runSimpleParser (handle mempty) s) Just (runSimpleParser p s)) + observing p = sStateT (\s -> case runSimpleParser p s of + Nothing -> Just (Left mempty,s) + Just (a,s') -> Just (Right a,s')) + eof = SimpleParser eof + token test _ = sStateT (\s -> case Mega.take1_ s of + Nothing -> Nothing + Just (t,s') -> case test t of + Nothing -> Nothing + Just a -> Just (a,s')) + tokens cmp xs = sStateT (\s -> case Mega.takeN_ (Mega.chunkLength (Proxy :: Proxy s) xs) s of + Nothing -> Nothing + Just (ys,s') -> if cmp xs ys then Just (xs,s') else Nothing) + getParserState = SimpleParser getDummyState + updateParserState f = sStateT (\s -> Just ((),(stateInput.f.dummyState) s)) + takeWhileP _ = SimpleParser . takeWhileP + takeWhile1P _ = SimpleParser . takeWhile1P + takeP _ = SimpleParser . countAny +#endif diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,263 @@ +{-- +Parsers form a semigroup in two ways: +Given parsers (p :: Parser s) and (q :: Parser s) +where s is the type of input stream (or any other semigroup) +there is the concatenation + +p <> q = do + x <- p + y <- q + return (x<>y) + +as well as the (backtracking) choice, try p <|> q. +In this test suite we test whether the ParsecT parser provided by megaparsec +and the SimpleParser provided in this package +behave identically under these two operations. +To this end, we randomly generate languages and parsers for them +and test both parsers on the words of the language. + +--} +{-# LANGUAGE + FlexibleContexts, + FlexibleInstances, + TypeFamilies, + OverloadedStrings, + DeriveGeneric, + DeriveFunctor, + RankNTypes, + ScopedTypeVariables +#-} +import Text.Megaparsec +import Text.Megaparsec.Simple +import Data.Void (Void) +import Data.String (IsString(..)) +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 + putStrLn "\ntesting whether the fast parser accepts words of the language" + Q.quickCheck (prop_AcceptsLang Fast) + putStrLn "testing whether the fast parser accepts the entire language" + Q.quickCheck (prop_AcceptsAllWords Fast) + putStrLn "testing whether parsers accept the same words" + Q.quickCheck (prop_AcceptSameWords) + putStrLn "testing whether lookAhead behaves identically" + Q.quickCheck prop_LookAhead + putStrLn "testing whether takeWhileP behaves identically" + Q.quickCheck prop_takeWhileP + putStrLn "testing whether takeWhile1P behaves identically" + Q.quickCheck prop_takeWhile1P + putStrLn "testing whether takeP behaves identically" + Q.quickCheck prop_takeP + +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) + +-- Tests whether 'genParser' accepts all words generated by 'genWords'. +-- This can take loooong if the language is large. +prop_AcceptsAllWords :: WhichParser -> Language (Set Text)-> Bool +prop_AcceptsAllWords which lang = all acceptsWord (allWords lang) where + acceptsWord :: Text -> Bool + acceptsWord w = isJust (case which of + Ordinary -> rightToMaybe (runParser (genParser lang <* eof :: Parsec Void Text Text) "test word" w) + Fast -> simpleParse (genParser lang <* eof) w) + +-- generates random words of the language and checks whether +-- the language parser accepts the word. +prop_AcceptsLang :: WhichParser -> Language (Set Text) -> Q.Property +prop_AcceptsLang which lang = let + parseWord = case which of + Ordinary -> rightToMaybe . runParser (genParser lang <* eof :: Parsec Void Text Text) "test word" + Fast -> simpleParse (genParser lang <* eof) + in Q.forAll (genWords lang) (\w -> isJust (parseWord w)) + +-- generates random words +-- and checks whether both the fast and ordinary parsers +-- accept them or not. +prop_AcceptSameWords :: Language (Set Text) -> Q.Property +prop_AcceptSameWords lang = let + p1 = rightToMaybe . runParser (genParser lang :: Parsec Void Text Text) "test word" + p2 = simpleParse (genParser lang) + maxLen = maxWord lang + in Q.forAll (fmap fromString (genWordQ `Q.suchThat` ((maxLen >=).length))) + (\w -> isJust (p1 w) Q.=== isJust (p2 w)) + +-- * Testing the MonadParsec primitives + +rightToMaybe :: Either a b -> Maybe b +rightToMaybe = either (const Nothing) Just + +simpleParse :: SimpleParser s a -> s -> Maybe a +simpleParse p = fmap fst . runSimpleParser p + +type GenericParser a = forall p. MonadParsec Void Text p => p a + +behaveEquallyOn :: forall a. (Show a, Eq a) => GenericParser a -> Text -> Q.Property +behaveEquallyOn p = let + run1 = rightToMaybe . runParser (p :: Parsec Void Text a) "input" + run2 = simpleParse p + in \input -> run1 input Q.=== run2 input + +genShortText :: Q.Gen Text +genShortText = Q.sized gen where + gen size = if size <= 0 + then fmap T.singleton genAlphaChar + else let size' = size `div` 2 in liftA2 (<>) (gen size') (gen size') + +{-- +newtype AlphaText = Alpha {getAlpha :: Text} +instance Arbitrary AlphaText where + arbitrary = fmap Alpha genShortText + shrink = const [Alpha mempty] +--} + +prop_LookAhead :: Q.Property +prop_LookAhead = Q.forAll genShortText $ \needle -> + Q.forAll genShortText $ \haystack -> + lookAhead (chunk needle) `behaveEquallyOn` haystack + +prop_takeWhileP :: Q.Property +prop_takeWhileP = Q.forAllBlind arbitrary $ \predicate -> + Q.forAll genShortText $ \input -> + (takeWhileP Nothing predicate) `behaveEquallyOn` input + +prop_takeWhile1P :: Q.Property +prop_takeWhile1P = Q.forAllBlind arbitrary $ \predicate -> + Q.forAll genShortText $ \input -> + (takeWhile1P Nothing predicate) `behaveEquallyOn` input + +prop_takeP :: Q.Property +prop_takeP = Q.forAll arbitrary $ \len -> + Q.forAll genShortText $ \input -> + (takeP Nothing len) `behaveEquallyOn` input