faster-megaparsec-0.1.1.0: test/Spec.hs

{--
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, 
    RankNTypes,
    ScopedTypeVariables
#-}
import GenLanguage -- randomly generate languages to parse
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 Control.Applicative (liftA2)
import Test.QuickCheck (Arbitrary(..))
import qualified Test.QuickCheck as Q
import Data.Set (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

-- | Parser selector. 'Ordinary' selects 'Parsec', 
-- 'Fast' selects 'SimpleParser'. 
data WhichParser = Fast | Ordinary

-- * checking the behaviour of parsers

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