picoparsec-0.1.1: tests/QC/Monoid.hs
{-# LANGUAGE BangPatterns, OverloadedStrings, ScopedTypeVariables, GADTs #-}
{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
module QC.Monoid (tests) where
import Prelude hiding (null, take, takeWhile)
import Control.Applicative ((<$>), (<*>), (*>), many, pure)
import Data.Monoid (Monoid, Sum(..), mempty, (<>))
import Data.String (fromString)
import Test.Tasty (TestTree)
import Test.Tasty.QuickCheck (testProperty)
import QC.Common (liftOp, parse)
import Test.QuickCheck
import Test.QuickCheck.Modifiers ()
import qualified Data.Picoparsec as P
import qualified Data.Picoparsec.State as PS
import qualified Data.ByteString as B
import qualified Data.Text as T hiding (break, singleton, span)
import qualified Data.Text.Lazy as LT
import qualified Data.Text.Encoding as TE
import Data.Monoid.Null (MonoidNull(null))
import Data.Monoid.Cancellative (LeftGCDMonoid)
import Data.Monoid.Factorial (FactorialMonoid(primePrefix, splitPrimePrefix))
import qualified Data.Monoid.Factorial as F
import qualified Data.Monoid.Textual as T
import Data.Monoid.Instances.ByteString.UTF8 (ByteStringUTF8(..), decode)
data Witness a where
ByteStringWitness :: Witness B.ByteString
StringWitness :: Witness String
TextWitness :: Witness T.Text
-- Basic byte-level combinators.
utf8 :: T.Text -> ByteStringUTF8
utf8 = ByteStringUTF8 . TE.encodeUtf8
satisfy :: (FactorialMonoid i, Ord i, Show i) => Witness i -> i -> Property
satisfy _ s = not (null w) ==> parse (P.satisfy (<= w)) s === Just w
where w = primePrefix s
maybeP :: Monoid t => P.Parser t r -> t -> Maybe r
maybeP p = P.maybeResult . flip P.feed mempty . P.parse p
satisfyWith :: forall i. (FactorialMonoid i, Ord i, Show i) => Witness i -> i -> i -> Property
satisfyWith _ p s = not (null p) ==> parse (P.satisfyWith id (<=c)) (c <> s) === Just c
where c = primePrefix p
defP :: Monoid i => P.Parser i r -> i -> P.IResult i r
defP p = flip P.feed mempty . P.parse p
char :: Char -> LT.Text -> Property
char w s = parse (P.char w) (LT.cons w s) === Just w
skip :: (FactorialMonoid i, Ord i, Show i) => Witness i -> i -> Property
skip _ ws = not (null ws) ==>
case (parse (P.skip (<w)) s, splitPrimePrefix s) of
(Nothing, mcs) -> maybe (property True) (expectFailure . it) mcs
(Just _, mcs) -> maybe (property False) it mcs
where it cs = liftOp "<" (<) (fst cs) w
Just (w, s) = splitPrimePrefix ws
satisfyChar :: Char -> T.Text -> Bool
satisfyChar c s = maybeP (P.satisfyChar (<=c)) (t <> s) == Just c
&& maybeP (P.satisfyChar (<=c)) (utf8 t <> utf8 s) == Just c
where t = T.singleton c
satisfyPartialChar :: (T.TextualMonoid i, i ~ T.Text) => Witness i -> Char -> i -> NonNegative Int -> Bool
satisfyPartialChar _ c s (NonNegative n) = P.maybeResult p' == Just c
where b = TE.encodeUtf8 (T.cons c s)
(b1, b2) = B.splitAt (n `mod` B.length b + 1) b
(u1, b1') = decode b1
u2 = ByteStringUTF8 (b1' <> b2)
p0 = P.satisfyChar (<=c)
p1 = P.parse p0 u1
p2 = if null u2 then p1 else P.feed p1 u2
p' = P.feed p2 mempty
anyToken :: (Eq i, FactorialMonoid i, Show i) => Witness i -> i -> Bool
anyToken _ s
| null s = p == Nothing
| otherwise = p == Just (F.take 1 s)
where p = maybeP P.anyToken s
anyChar :: T.TextualMonoid i => Witness i -> i -> Bool
anyChar _ s = maybeP P.anyChar s == T.characterPrefix s
notChar :: forall a. T.TextualMonoid a => Witness a -> Char -> NonEmptyList Char -> Property
notChar _ w (NonEmpty s) = parse (P.notChar w) bs === if v == Just w
then Nothing
else v
where v = T.characterPrefix bs
bs = fromString s :: a
peekChar :: (Eq i, T.TextualMonoid i, Show i) => Witness i -> i -> Property
peekChar _ s
| null s = p === Just (Nothing, s)
| otherwise = p === Just (T.characterPrefix s, s)
where p = maybeP ((,) <$> P.peekChar <*> P.takeRest) s
peekChar' :: T.TextualMonoid i => Witness i -> i -> Property
peekChar' _ s = parse P.peekChar' s === (fst <$> T.splitCharacterPrefix s)
string :: (Eq i, LeftGCDMonoid i, MonoidNull i, Show i) => Witness i -> i -> i -> Property
string _ s t = parse (P.string s) (s <> t) === Just s
anyPartialChar :: (Eq i, T.TextualMonoid i, Show i, i ~ T.Text) => Witness i -> i -> NonNegative Int -> Bool
anyPartialChar _ s (NonNegative n)
| T.null s = maybeP p0 (ByteStringUTF8 b) == Nothing
| otherwise = P.maybeResult p' == Just (T.head s)
where b = TE.encodeUtf8 s
(b1, b2) = B.splitAt (n `mod` B.length b + 1) b
(u1, b1') = decode b1
u2 = ByteStringUTF8 (b1' <> b2)
p0 = P.anyChar
p1 = P.parse p0 u1
p2 = if null u2 then p1 else P.feed p1 u2
p' = P.feed p2 mempty
peekToken :: (Eq i, FactorialMonoid i, Show i) => Witness i -> i -> Property
peekToken _ s
| null s = p === Just (mempty, s)
| otherwise = p === Just (F.take 1 s, s)
where p = maybeP ((,) <$> P.peekToken <*> P.takeRest) s
skipWhile :: Char -> LT.Text -> Property
skipWhile w s =
let t = LT.dropWhile (<= w) s
in case defP (P.skipWhile (<= LT.singleton w)) s of
P.Done t' () -> t === t'
_ -> property False
take :: (Eq i, FactorialMonoid i, Show i) => Witness i -> Int -> i -> Property
take _ n s = maybe (liftOp "<" (<) (F.length s) (fromIntegral n))
(=== F.take n s) $
parse (P.take n) s
takeRest :: (Eq i, MonoidNull i, Show i) => Witness i -> i -> Property
takeRest _ s = maybe (property False) (=== s) . maybeP P.takeRest $ s
takeCount :: FactorialMonoid i => Witness i -> Positive Int -> i -> Property
takeCount _ (Positive k) s = not (null s) ==>
case parse (P.take k) s of
Nothing -> liftOp ">" (>) (fromIntegral k) (F.length s)
Just _s -> liftOp "<=" (<=) (fromIntegral k) (F.length s)
takeWhile :: (Eq i, FactorialMonoid i, Show i) => Witness i -> i -> Property
takeWhile _ ws = not (null ws) ==>
let (h,t) = F.span (==w) s
Just (w,s) = splitPrimePrefix ws
in case maybeP ((,) <$> P.takeWhile (==w) <*> P.takeRest) s of
Just (h', t') -> t === t' .&&. h === h'
_ -> property False
takeCharsWhile :: (Eq i, T.TextualMonoid i, Show i) => Witness i -> Char -> i -> Property
takeCharsWhile _ w s =
let (h,t) = T.span (const False) (==w) s
in case maybeP ((,) <$> P.takeCharsWhile (==w) <*> P.takeRest) s of
Just (h', t') -> t === t' .&&. h === h'
_ -> property False
takePartialCharsWhile :: (Ord i, T.TextualMonoid i, Show i, i ~ T.Text) => Witness i -> Char -> i -> NonNegative Int -> Bool
takePartialCharsWhile _ c s (NonNegative n) =
case p' of
P.Done t' h' -> utf8 t == t' && utf8 h == h'
_ -> False
where (h,t) = T.span (const False) (<=c) s
b = TE.encodeUtf8 s
(b1, b2) = B.splitAt (if B.null b then 0 else n `mod` B.length b + 1) b
(u1, b1') = decode b1
u2 = ByteStringUTF8 (b1' <> b2)
p0 = P.takeCharsWhile (<= c)
p1 = P.parse p0 u1
p2 = if null u2 then p1 else P.feed p1 u2
p' = P.feed p2 mempty
takeWhile1 :: (Ord i, FactorialMonoid i) => Witness i -> i -> Property
takeWhile1 _ ws = not (null ws) ==>
let s' = w <> s
(h,t) = F.span (<=w) s'
Just (w, s) = splitPrimePrefix ws
in case defP (P.takeWhile1 (<= w)) s' of
P.Done t' h' -> t == t' && h == h'
_ -> False
takeCharsWhile1 :: (Ord i, T.TextualMonoid i, Show i) => Witness i -> Char -> i -> Bool
takeCharsWhile1 _ c s =
let s' = T.singleton c <> s
(h,t) = T.span (const False) (<=c) s'
in case defP (P.takeCharsWhile1 (<= c)) s' of
P.Done t' h' -> t == t' && h == h'
_ -> False
takePartialCharsWhile1 :: (Eq i, T.TextualMonoid i, Show i, i ~ T.Text) => Witness i -> Char -> i -> NonNegative Int -> Bool
takePartialCharsWhile1 _ c s (NonNegative n) =
case p' of
P.Done t' h' -> utf8 t == t' && utf8 h == h'
_ -> False
where b = TE.encodeUtf8 s'
s' = T.cons c s
(h,t) = T.span (const False) (<=c) s'
(b1, b2) = B.splitAt (if B.null b then 0 else n `mod` B.length b + 1) b
(u1, b1') = decode b1
u2 = ByteStringUTF8 (b1' <> b2)
p0 = P.takeCharsWhile1 (<= c)
p1 = P.parse p0 u1
p2 = if null u2 then p1 else P.feed p1 u2
p' = P.feed p2 mempty
takeTill :: (Eq i, FactorialMonoid i) => Witness i -> i -> Property
takeTill _ ws = not (null ws) ==>
let (h,t) = F.break (== w) s
Just (w, s) = splitPrimePrefix ws
in case defP (P.takeTill (== w)) s of
P.Done t' h' -> t == t' && h == h'
_ -> False
takeCharsTill :: (Eq i, T.TextualMonoid i) => Witness i -> Char -> i -> Bool
takeCharsTill _ c s =
let (h,t) = T.break (const False) (== c) s
in case defP (P.takeCharsTill (== c)) s of
P.Done t' h' -> t == t' && h == h'
_ -> False
takeTillChar :: (Eq i, T.TextualMonoid i) => Witness i -> Char -> i -> Bool
takeTillChar _ c s =
let (h,t) = T.break (const False) (<= c) s
in case defP (P.takeTillChar (<= c)) s of
P.Done t' h' -> t == t' && h == h'
_ -> False
takeTillPartialChar :: (Eq i, T.TextualMonoid i, i ~ T.Text) => Witness i -> Char -> i -> NonNegative Int -> Bool
takeTillPartialChar _ c s (NonNegative n) =
case p' of
P.Done t' h' -> utf8 t == t' && utf8 h == h'
_ -> False
where (h,t) = T.break (const False) (<= c) s
b = TE.encodeUtf8 s
(b1, b2) = B.splitAt (if B.null b then 0 else n `mod` B.length b + 1) b
(u1, b1') = decode b1
u2 = ByteStringUTF8 (b1' <> b2)
p0 = P.takeTillChar (<= c)
p1 = P.parse p0 u1
p2 = if null u2 then p1 else P.feed p1 u2
p' = P.feed p2 mempty
takeTillChar1 :: (Eq i, T.TextualMonoid i) => Witness i -> Char -> i -> Bool
takeTillChar1 _ c s =
let s' = T.singleton c <> s
(h,t) = T.break (const False) (< c) s'
in case defP (P.takeTillChar1 (< c)) s' of
P.Done t' h' -> t == t' && h == h'
_ -> False
takeTillPartialChar1 :: (Eq i, T.TextualMonoid i, i ~ T.Text) => Witness i -> Char -> i -> NonNegative Int -> Bool
takeTillPartialChar1 _ c s (NonNegative n) =
case p' of
P.Done t' h' -> utf8 t == t' && utf8 h == h'
_ -> False
where s' = T.singleton c <> s
(h,t) = T.break (const False) (< c) s'
b = TE.encodeUtf8 s'
(b1, b2) = B.splitAt (n `mod` B.length b + 1) b
(u1, b1') = decode b1
u2 = ByteStringUTF8 (b1' <> b2)
p0 = P.takeTillChar1 (< c)
p1 = P.parse p0 u1
p2 = if null u2 then p1 else P.feed p1 u2
p' = P.feed p2 mempty
takeWhile1_empty :: forall i. (Eq i, FactorialMonoid i) => Witness i -> Bool
takeWhile1_empty _ = maybeP (P.takeWhile1 undefined) (mempty :: i) == Nothing
endOfInput :: (Eq i, MonoidNull i) => Witness i -> i -> Property
endOfInput _ s = maybeP P.endOfInput s === if null s
then Just ()
else Nothing
stateful :: String -> Bool
stateful s = maybeP (many (PS.modifyState (+ (Sum 1)) *> P.anyChar) *> PS.getState) (pure s)
== Just (Sum (length s))
endOfLine :: (Eq i, T.TextualMonoid i) => Witness i -> i -> Property
endOfLine _ s =
case (parse P.endOfLine s, T.splitCharacterPrefix s) of
(Nothing, mcs) -> maybe (property True) (expectFailure . eol) mcs
(Just _, mcs) -> maybe (property False) eol mcs
where eol (c,s') = c === '\n' .||.
(c, fst <$> T.splitCharacterPrefix s') === ('\r', Just '\n')
scan :: (Eq i, T.TextualMonoid i, Show i) => Witness i -> i -> Positive Int -> Property
scan _ s (Positive k) = maybeP p s === Just (F.take k s)
where p = P.scan k $ \ n _ ->
if n > 0 then let !n' = n - 1 in Just n' else Nothing
tests :: [TestTree]
tests = [
testProperty "anyChar" (anyChar TextWitness)
, testProperty "char" char
, testProperty "notChar" (notChar TextWitness),
testProperty "satisfyChar" satisfyChar,
testProperty "satisfyPartialChar" (satisfyPartialChar TextWitness),
testProperty "anyToken" (anyToken ByteStringWitness),
testProperty "endOfLine" (endOfLine TextWitness),
testProperty "anyPartialChar" (anyPartialChar TextWitness),
testProperty "peekToken" (peekToken ByteStringWitness)
, testProperty "peekChar" (peekChar TextWitness)
, testProperty "peekChar'" (peekChar' TextWitness)
, testProperty "satisfy" (satisfy ByteStringWitness)
, testProperty "satisfyWith" (satisfyWith ByteStringWitness)
, testProperty "scan" (scan TextWitness)
, testProperty "skip" (skip ByteStringWitness)
, testProperty "skipWhile" skipWhile
, testProperty "string" (string TextWitness)
, testProperty "take" (take ByteStringWitness)
, testProperty "takeRest" (takeRest ByteStringWitness)
, testProperty "takeCount" (takeCount ByteStringWitness)
, testProperty "takeTill" (takeTill ByteStringWitness),
testProperty "takeCharsTill" (takeCharsTill TextWitness),
testProperty "takeTillChar" (takeTillChar TextWitness),
testProperty "takeTillPartialChar" (takeTillPartialChar TextWitness),
testProperty "takeTillChar1" (takeTillChar1 TextWitness),
testProperty "takeTillPartialChar1" (takeTillPartialChar1 TextWitness)
, testProperty "takeWhile" (takeWhile ByteStringWitness)
, testProperty "takeWhile1" (takeWhile1 ByteStringWitness)
, testProperty "takeWhile1_empty" (takeWhile1_empty ByteStringWitness),
testProperty "takeCharsWhile" (takeCharsWhile TextWitness),
testProperty "takeCharsWhile1" (takeCharsWhile1 TextWitness),
testProperty "takePartialCharsWhile" (takePartialCharsWhile TextWitness),
testProperty "takePartialCharsWhile1" (takePartialCharsWhile1 TextWitness),
testProperty "endOfInput" (endOfInput ByteStringWitness),
testProperty "stateful" stateful
]