{-# LANGUAGE OverloadedStrings #-} module QC.Combinator where import Control.Applicative ((<$>), (<*>)) import Data.List (isPrefixOf) import Data.Maybe (fromJust, isJust) import Data.Monoid (mempty) import Data.Word (Word8) import QC.Common (Repack, parse, repackBS, toStrictBS) import Test.Tasty (TestTree) import Test.Tasty.QuickCheck (testProperty) import Test.QuickCheck import qualified Data.Picoparsec as P import qualified Data.Picoparsec.Combinator as C import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Char8 as B8 choice :: NonEmptyList (NonEmptyList Word8) -> Gen Property choice (NonEmpty xs) = do let ys = map (BL.pack . getNonEmpty) xs return . forAll (repackBS <$> arbitrary <*> (toStrictBS <$> elements ys)) $ maybe False (`elem` ys) . P.maybeResult . flip P.feed mempty . P.parse (C.choice (map P.string ys)) count :: Positive (Small Int) -> Repack -> B8.ByteString -> Bool count (Positive (Small n)) rs s = (length <$> parse (C.count n (P.string s)) (BL.toStrict input)) == Just n where input = repackBS rs (B8.concat (replicate (n+1) s)) lookAhead :: NonEmptyList Word8 -> Bool lookAhead (NonEmpty xs) = let ys = B.pack xs withLookAheadThenConsume = (,) <$> C.lookAhead (P.string ys) <*> P.string ys mr = parse withLookAheadThenConsume ys in isJust mr && fst (fromJust mr) == snd (fromJust mr) notFollowedBy :: NonEmptyList Word8 -> NonEmptyList Word8 -> Bool notFollowedBy (NonEmpty xs) (NonEmpty ys) = let xs' = B.pack xs ys' = B.pack ys withNotFollowedByThenConsume = (,) <$> C.notFollowedBy (P.string xs') <*> P.string ys' mr = parse withNotFollowedByThenConsume ys' in mr == if xs `isPrefixOf` ys || ys `isPrefixOf` xs then Nothing else Just ((), ys') {- match :: Int -> NonNegative Int -> NonNegative Int -> Repack -> Bool match n (NonNegative x) (NonNegative y) rs = parse (P.match parser) (repackBS rs input) == Just (input, n) where parser = P.skipWhile (=='x') *> P.signed P.decimal <* P.skipWhile (=='y') input = B8.concat [ B8.replicate x 'x', B8.pack (show n), B8.replicate y 'y' ] -} tests :: [TestTree] tests = [ testProperty "choice" choice , testProperty "count" count -- , testProperty "match" match , testProperty "lookAhead" lookAhead , testProperty "notFollowedBy" notFollowedBy ]