{-# 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 -- Basic byte-level combinators. 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 ]