{--
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