{-# LANGUAGE BangPatterns, OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
module QC.Text (tests) where
import Control.Applicative ((<$>), (<*>))
import Data.Int (Int64)
import Prelude hiding (take, takeWhile)
import QC.Common (liftOp, parseT)
import Test.Framework (Test)
import Test.Framework.Providers.QuickCheck2 (testProperty)
import Test.QuickCheck
import qualified Data.Attoparsec.Text as P
import qualified Data.Attoparsec.Text.Lazy as PL
import qualified Data.Char as Char
import qualified Data.Text as T
import qualified Data.Text.Lazy as L
satisfy :: Char -> L.Text -> Property
satisfy w s = parseT (P.satisfy (<=w)) (L.cons w s) === Just w
satisfyWith :: Char -> L.Text -> Property
satisfyWith c s = parseT (P.satisfyWith id (<=c)) (L.cons c s) === Just c
char :: Char -> L.Text -> Property
char w s = parseT (P.char w) (L.cons w s) === Just w
skip :: Char -> L.Text -> Property
skip w s =
case (parseT (P.skip (<w)) s, L.uncons s) of
(Nothing, mcs) -> maybe (property True) (expectFailure . it) mcs
(Just _, mcs) -> maybe (property False) it mcs
where it cs = liftOp "<" (<) (fst cs) w
anyChar :: L.Text -> Property
anyChar s
| L.null s = p === Nothing
| otherwise = p === Just (L.head s)
where p = parseT P.anyChar s
notChar :: Char -> NonEmptyList Char -> Property
notChar w (NonEmpty s) = parseT (P.notChar w) bs === if v == w
then Nothing
else Just v
where v = L.head bs
bs = L.pack s
peekChar :: L.Text -> Property
peekChar s
| L.null s = p === Just (Nothing, s)
| otherwise = p === Just (Just (L.head s), s)
where p = parseT ((,) <$> P.peekChar <*> P.takeLazyText) s
peekChar' :: L.Text -> Property
peekChar' s = parseT P.peekChar' s === (fst <$> L.uncons s)
string :: L.Text -> L.Text -> Property
string s t = parseT (P.string s') (s `L.append` t) === Just s'
where s' = toStrict s
stringCI :: T.Text -> Property
stringCI s = P.parseOnly (P.stringCI fs) s === Right s
where fs = T.toCaseFold s
asciiCI :: T.Text -> Gen Bool
asciiCI x =
(\s i -> P.parseOnly (P.asciiCI s) i == Right i)
<$> maybeModifyCase x
<*> maybeModifyCase x
where
maybeModifyCase s = elements [s, toLower s, toUpper s]
toLower = T.map (\c -> if c < Char.chr 127 then Char.toLower c else c)
toUpper = T.map (\c -> if c < Char.chr 127 then Char.toUpper c else c)
toStrict :: L.Text -> T.Text
toStrict = T.concat . L.toChunks
skipWhile :: Char -> L.Text -> Property
skipWhile w s =
let t = L.dropWhile (<=w) s
in case PL.parse (P.skipWhile (<=w)) s of
PL.Done t' () -> t === t'
_ -> property False
take :: Int -> L.Text -> Property
take n s = maybe (liftOp "<" (<) (L.length s) (fromIntegral n))
(=== T.take n (toStrict s)) $
parseT (P.take n) s
takeText :: L.Text -> Property
takeText s = maybe (property False) (=== toStrict s) . parseT P.takeText $ s
takeLazyText :: L.Text -> Property
takeLazyText s = maybe (property False) (=== s) . parseT P.takeLazyText $ s
takeCount :: Positive Int -> L.Text -> Property
takeCount (Positive k) s =
case parseT (P.take k) s of
Nothing -> liftOp ">" (>) (fromIntegral k) (L.length s)
Just _s -> liftOp "<=" (<=) (fromIntegral k) (L.length s)
takeWhile :: Char -> L.Text -> Property
takeWhile w s =
let (h,t) = L.span (==w) s
in case PL.parse (P.takeWhile (==w)) s of
PL.Done t' h' -> t === t' .&&. toStrict h === h'
_ -> property False
takeWhile1 :: Char -> L.Text -> Property
takeWhile1 w s =
let s' = L.cons w s
(h,t) = L.span (<=w) s'
in case PL.parse (P.takeWhile1 (<=w)) s' of
PL.Done t' h' -> t === t' .&&. toStrict h === h'
_ -> property False
takeTill :: Char -> L.Text -> Property
takeTill w s =
let (h,t) = L.break (==w) s
in case PL.parse (P.takeTill (==w)) s of
PL.Done t' h' -> t === t' .&&. toStrict h === h'
_ -> property False
takeWhile1_empty :: Property
takeWhile1_empty = parseT (P.takeWhile1 undefined) L.empty === Nothing
endOfInput :: L.Text -> Property
endOfInput s = parseT P.endOfInput s === if L.null s
then Just ()
else Nothing
endOfLine :: L.Text -> Property
endOfLine s =
case (parseT P.endOfLine s, L.uncons 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 <$> L.uncons s') === ('\r', Just '\n')
scan :: L.Text -> Positive Int64 -> Property
scan s (Positive k) = parseT p s === Just (toStrict $ L.take k s)
where p = P.scan k $ \ n _ ->
if n > 0 then let !n' = n - 1 in Just n' else Nothing
tests :: [Test]
tests = [
testProperty "anyChar" anyChar
, testProperty "asciiCI" asciiCI
, testProperty "char" char
, testProperty "endOfInput" endOfInput
, testProperty "endOfLine" endOfLine
, testProperty "notChar" notChar
, testProperty "peekChar" peekChar
, testProperty "peekChar'" peekChar'
, testProperty "satisfy" satisfy
, testProperty "satisfyWith" satisfyWith
, testProperty "scan" scan
, testProperty "skip" skip
, testProperty "skipWhile" skipWhile
, testProperty "string" string
, testProperty "stringCI" stringCI
, testProperty "take" take
, testProperty "takeText" takeText
, testProperty "takeCount" takeCount
, testProperty "takeLazyText" takeLazyText
, testProperty "takeTill" takeTill
, testProperty "takeWhile" takeWhile
, testProperty "takeWhile1" takeWhile1
, testProperty "takeWhile1_empty" takeWhile1_empty
]