picoparsec-0.1: tests/QC/Monoid.hs
{-# LANGUAGE BangPatterns, OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-missing-signatures -fno-warn-orphans #-}
module QC.Monoid (tests) where
import Prelude hiding (null, takeWhile)
import Control.Applicative ((<$>), (<*>), (*>), many, pure)
import Data.Monoid (Monoid, Sum(..), mempty, (<>))
import Data.Word (Word8)
import Test.Tasty.QuickCheck (testProperty)
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.ByteString.Lazy as L
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import Data.Monoid.Null (null)
import Data.Monoid.Instances.ByteString.UTF8 (ByteStringUTF8(..), decode)
instance Arbitrary B.ByteString where
arbitrary = B.pack <$> arbitrary
instance Arbitrary L.ByteString where
arbitrary = sized $ \n -> resize (round (sqrt (toEnum n :: Double)))
((L.fromChunks . map (B.pack . nonEmpty)) <$> arbitrary)
where nonEmpty (NonEmpty a) = a
instance Arbitrary T.Text where
arbitrary = T.pack <$> arbitrary
-- Naming.
{-
label (NonEmpty s) = case parse (anyToken <?> s) B.empty of
(_, Left err) -> s `isInfixOf` err
_ -> False
-}
-- Basic byte-level combinators.
utf8 :: T.Text -> ByteStringUTF8
utf8 = ByteStringUTF8 . TE.encodeUtf8
maybeP :: Monoid t => P.Parser t r -> t -> Maybe r
maybeP p = P.maybeResult . flip P.feed mempty . P.parse p
defP p = flip P.feed mempty . P.parse p
satisfy :: Word8 -> B.ByteString -> Bool
satisfy w s = maybeP (P.satisfy (<=b)) (b <> s) == Just b
where b = B.singleton w
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 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 s
| L.null s = p == Nothing
| otherwise = p == Just (L.take 1 s)
where p = maybeP P.anyToken s
anyChar s
| T.null s = p == Nothing
| otherwise = p == Just (T.head s)
where p = maybeP P.anyChar s
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 s
| L.null s = p == Just (L.empty, s)
| otherwise = p == Just (L.take 1 s, s)
where p = maybeP ((,) <$> P.peekToken <*> P.takeRest) s
string s t = maybeP (P.string s) (s `L.append` t) == Just s
skipWhile w s =
let t = L.dropWhile (<= w) s
in case defP (P.skipWhile (<= L.singleton w)) s of
P.Done t' () -> t == t'
_ -> False
takeCount (Positive k) s =
case maybeP (P.take k) s of
Nothing -> fromIntegral k > L.length s
Just s' -> fromIntegral k <= L.length s'
takeWhile w s =
let (h,t) = L.span (<=w) s
in case defP (P.takeWhile (<= L.singleton w)) s of
P.Done t' h' -> t == t' && h == h'
_ -> False
takeCharsWhile c s =
let (h,t) = T.span (<=c) s
in case defP (P.takeCharsWhile (<= c)) s of
P.Done t' h' -> t == t' && h == h'
_ -> False
takePartialCharsWhile c s (NonNegative n) =
case p' of
P.Done t' h' -> utf8 t == t' && utf8 h == h'
_ -> False
where (h,t) = T.span (<=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 w s =
let s' = L.cons w s
(h,t) = L.span (<=w) s'
in case defP (P.takeWhile1 (<= L.singleton w)) s' of
P.Done t' h' -> t == t' && h == h'
_ -> False
takeCharsWhile1 c s =
let s' = T.cons c s
(h,t) = T.span (<=c) s'
in case defP (P.takeWhile1 (<= T.singleton c)) s' of
P.Done t' h' -> t == t' && h == h'
_ -> False
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 (<=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 w s =
let (h,t) = L.break (== w) s
in case defP (P.takeTill (== L.singleton w)) s of
P.Done t' h' -> t == t' && h == h'
_ -> False
takeCharsTill c s =
let (h,t) = T.break (== c) s
in case defP (P.takeCharsTill (== c)) s of
P.Done t' h' -> t == t' && h == h'
_ -> False
takeTillChar c s =
let (h,t) = T.break (<= c) s
in case defP (P.takeTillChar (<= c)) s of
P.Done t' h' -> t == t' && h == h'
_ -> False
takeTillPartialChar c s (NonNegative n) =
case p' of
P.Done t' h' -> utf8 t == t' && utf8 h == h'
_ -> False
where (h,t) = T.break (<= 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 c s =
let s' = T.cons c s
(h,t) = T.break (< c) s'
in case defP (P.takeTillChar1 (< c)) s' of
P.Done t' h' -> t == t' && h == h'
_ -> False
takeTillPartialChar1 c s (NonNegative n) =
case p' of
P.Done t' h' -> utf8 t == t' && utf8 h == h'
_ -> False
where s' = T.cons c s
(h,t) = T.break (< 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 = maybeP (P.takeWhile1 undefined) L.empty == Nothing
endOfInput s = maybeP P.endOfInput s == if B.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))
tests = [
testProperty "satisfy" satisfy,
testProperty "satisfyChar" satisfyChar,
testProperty "satisfyPartialChar" satisfyPartialChar,
testProperty "anyToken" anyToken,
testProperty "anyChar" anyChar,
testProperty "anyPartialChar" anyPartialChar,
testProperty "peekToken" peekToken,
testProperty "string" string,
testProperty "skipWhile" skipWhile,
testProperty "takeCount" takeCount,
testProperty "takeWhile" takeWhile,
testProperty "takeCharsWhile" takeCharsWhile,
testProperty "takePartialCharsWhile" takePartialCharsWhile,
testProperty "takeWhile1" takeWhile1,
testProperty "takeWhile1_empty" takeWhile1_empty,
testProperty "takeCharsWhile1" takeCharsWhile1,
testProperty "takePartialCharsWhile1" takePartialCharsWhile1,
testProperty "takeTill" takeTill,
testProperty "takeCharsTill" takeCharsTill,
testProperty "takeTillChar" takeTillChar,
testProperty "takeTillPartialChar" takeTillPartialChar,
testProperty "takeTillChar1" takeTillChar1,
testProperty "takeTillPartialChar1" takeTillPartialChar1,
testProperty "endOfInput" endOfInput,
testProperty "stateful" stateful
]