@@ -13,6 +13,7 @@ import Test.QuickCheck
1313import Test.QuickCheck.Monadic
1414import Text.Show.Functions ()
1515
16+import Control.Applicative ((<$>), (<*>))
1617import Control.Arrow ((***), second)
1718import Control.Exception (catch)
1819import Data.Char (chr, isDigit, isHexDigit, isLower, isSpace, isUpper, ord)
@@ -110,23 +111,55 @@ t_utf8_incr = do
110111 E.Some t _ f' = f a
111112 in t : feedChunksOf n f' b
112113
113−-- This is a poor attempt to ensure that the error handling paths on
114−-- decode are exercised in some way. Proper testing would be rather
115−-- more involved.
116−t_utf8_err :: DecodeErr -> B.ByteString -> Property
117−t_utf8_err (DE _ de) bs = monadicIO $ do
118− l <- run $ let len = T.length (E.decodeUtf8With de bs)
119− in (len `seq` return (Right len)) `catch`
120− (\(e::UnicodeException) -> return (Left e))
121− case l of
122− Left err -> assert $ length (show err) >= 0
123− Right n -> assert $ n >= 0
114+data Badness = Solo | Leading | Trailing
115+ deriving (Eq, Show)
116+
117+instance Arbitrary Badness where
118+ arbitrary = elements [Solo, Leading, Trailing]
119+
120+t_utf8_err :: Badness -> DecodeErr -> Property
121+t_utf8_err bad de = do
122+ let gen = case bad of
123+ Solo -> genInvalidUTF8
124+ Leading -> B.append <$> genInvalidUTF8 <*> genUTF8
125+ Trailing -> B.append <$> genUTF8 <*> genInvalidUTF8
126+ genUTF8 = E.encodeUtf8 <$> genUnicode
127+ forAll gen $ \bs -> do
128+ onErr <- genDecodeErr de
129+ monadicIO $ do
130+ l <- run $ let len = T.length (E.decodeUtf8With onErr bs)
131+ in (len `seq` return (Right len)) `catch`
132+ (\(e::UnicodeException) -> return (Left e))
133+ assert $ case l of
134+ Left err -> length (show err) >= 0
135+ Right _ -> de /= Strict
124136
125137t_utf8_err' :: B.ByteString -> Property
126138t_utf8_err' bs = monadicIO . assert $ case E.decodeUtf8' bs of
127139 Left err -> length (show err) >= 0
128140 Right t -> T.length t >= 0
129141
142+genInvalidUTF8 :: Gen B.ByteString
143+genInvalidUTF8 = B.pack <$> oneof [
144+ -- invalid leading byte of a 2-byte sequence
145+ (:) <$> choose (0xC0, 0xC1) <*> upTo 1 contByte
146+ -- invalid leading byte of a 4-byte sequence
147+ , (:) <$> choose (0xF5, 0xFF) <*> upTo 3 contByte
148+ -- continuation bytes without a start byte
149+ , listOf1 contByte
150+ -- short 2-byte sequence
151+ , (:[]) <$> choose (0xC2, 0xDF)
152+ -- short 3-byte sequence
153+ , (:) <$> choose (0xE0, 0xEF) <*> upTo 1 contByte
154+ -- short 4-byte sequence
155+ , (:) <$> choose (0xF0, 0xF4) <*> upTo 2 contByte
156+ ]
157+ where
158+ contByte = (0x80 +) <$> choose (0, 0x3f)
159+ upTo n gen = do
160+ k <- choose (0,n)
161+ vectorOf k gen
162+
130163s_Eq s = (s==) `eq` ((S.streamList s==) . S.streamList)
131164 where _types = s :: String
132165sf_Eq p s =