Combinator.hs

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