Merge fix for gh-61 into 1.0 branch
authorBryan O'Sullivan <bos@serpentine.com>
Mon, 30 Dec 2013 08:36:14 +0000 (00:36 -0800)
committerBryan O'Sullivan <bos@serpentine.com>
Mon, 30 Dec 2013 08:36:14 +0000 (00:36 -0800)
1  2 
cbits/cbits.c
tests/Tests/Properties.hs

diff --cc cbits/cbits.c
@@@ -127,14 -123,21 +127,21 @@@ _hs_text_decode_latin1(uint16_t *dest, 
   *      state0 != UTF8_ACCEPT, UTF8_REJECT
   *
   */
- const uint8_t *
- _hs_text_decode_utf8_state(uint16_t *const dest, size_t *destoff,
-                            const uint8_t **const src,
-                            const uint8_t *const srcend,
-                            uint32_t *codepoint0, uint32_t *state0)
 -
+ #if defined(__GNUC__) || defined(__clang__)
+ static inline uint8_t const *
 -_hs_text_decode_utf8_int(uint16_t *dest, size_t *destoff,
 -                       const uint8_t const *src, const uint8_t const *srcend,
++_hs_text_decode_utf8_int(uint16_t *const dest, size_t *destoff,
++                       const uint8_t const **src, const uint8_t const *srcend,
+                        uint32_t *codepoint0, uint32_t *state0)
+   __attribute((always_inline));
+ #endif
++
+ static inline uint8_t const *
 -_hs_text_decode_utf8_int(uint16_t *dest, size_t *destoff,
 -                       const uint8_t const *src, const uint8_t const *srcend,
++_hs_text_decode_utf8_int(uint16_t *const dest, size_t *destoff,
++                       const uint8_t const **src, const uint8_t const *srcend,
+                        uint32_t *codepoint0, uint32_t *state0)
  {
    uint16_t *d = dest + *destoff;
 -  const uint8_t const *s = src;
 +  const uint8_t *s = *src, *last = *src;
    uint32_t state = *state0;
    uint32_t codepoint = *codepoint0;
  
        *d++ = (uint16_t) (0xD7C0 + (codepoint >> 10));
        *d++ = (uint16_t) (0xDC00 + (codepoint & 0x3FF));
      }
 +    last = s;
    }
  
-   /* Invalid encoding, back up to the errant character */
-   if (state == UTF8_REJECT)
-     s -= 1;
    *destoff = d - dest;
    *codepoint0 = codepoint;
    *state0 = state;
    return s;
  }
  
 -_hs_text_decode_utf8_state(uint16_t *dest, size_t *destoff,
 -                           const uint8_t const *src,
+ uint8_t const *
++_hs_text_decode_utf8_state(uint16_t *const dest, size_t *destoff,
++                           const uint8_t const **src,
+                          const uint8_t const *srcend,
+                            uint32_t *codepoint0, uint32_t *state0)
+ {
+   uint8_t const *ret = _hs_text_decode_utf8_int(dest, destoff, src, srcend,
+                                               codepoint0, state0);
+   if (*state0 == UTF8_REJECT)
+     ret -=1;
+   return ret;
+ }
  /*
   * Helper to decode buffer and discard final decoder state
   */
@@@ -206,5 -215,10 +222,10 @@@ _hs_text_decode_utf8(uint16_t *const de
  {
    uint32_t codepoint;
    uint32_t state = UTF8_ACCEPT;
-   return _hs_text_decode_utf8_state(dest, destoff, &src, srcend, &codepoint, &state);
 -  uint8_t const *ret = _hs_text_decode_utf8_int(dest, destoff, src, srcend,
++  uint8_t const *ret = _hs_text_decode_utf8_int(dest, destoff, &src, srcend,
+                                               &codepoint, &state);
+   /* Back up if we have an incomplete or invalid encoding */
+   if (state != UTF8_ACCEPT)
+     ret -= 1;
+   return ret;
  }
@@@ -98,29 -94,28 +99,40 @@@ tl_utf32LE   = forAll genUnicode $ (EL.
  t_utf32BE    = forAll genUnicode $ (E.decodeUtf32BE . E.encodeUtf32BE) `eq` id
  tl_utf32BE   = forAll genUnicode $ (EL.decodeUtf32BE . EL.encodeUtf32BE) `eq` id
  
- -- This is a poor attempt to ensure that the error handling paths on
- -- decode are exercised in some way.  Proper testing would be rather
- -- more involved.
- t_utf8_err :: DecodeErr -> B.ByteString -> Property
- t_utf8_err (DE _ de) bs = monadicIO $ do
-   l <- run $ let len = T.length (E.decodeUtf8With de bs)
-              in (len `seq` return (Right len)) `catch`
-                 (\(e::UnicodeException) -> return (Left e))
-   case l of
-     Left err -> assert $ length (show err) >= 0
-     Right n  -> assert $ n >= 0
 +t_utf8_incr  = do
 +        Positive n <- arbitrary
 +        forAll genUnicode $ recode n `eq` id
 +    where recode n = T.concat . feedChunksOf n E.streamDecodeUtf8 . E.encodeUtf8
 +          feedChunksOf :: Int -> (B.ByteString -> E.Decoding) -> B.ByteString
 +                       -> [T.Text]
 +          feedChunksOf n f bs
 +            | B.null bs  = []
 +            | otherwise  = let (a,b) = B.splitAt n bs
 +                               E.Some t _ f' = f a
 +                           in t : feedChunksOf n f' b
 +
+ data Badness = Solo | Leading | Trailing
+              deriving (Eq, Show)
+ instance Arbitrary Badness where
+     arbitrary = elements [Solo, Leading, Trailing]
+ t_utf8_err :: Badness -> DecodeErr -> Property
+ t_utf8_err bad de = do
+   let gen = case bad of
+         Solo     -> genInvalidUTF8
+         Leading  -> B.append <$> genInvalidUTF8 <*> genUTF8
+         Trailing -> B.append <$> genUTF8 <*> genInvalidUTF8
+       genUTF8 = E.encodeUtf8 <$> genUnicode
+   forAll gen $ \bs -> do
+     onErr <- genDecodeErr de
+     monadicIO $ do
+     l <- run $ let len = T.length (E.decodeUtf8With onErr bs)
+                in (len `seq` return (Right len)) `catch`
+                   (\(e::UnicodeException) -> return (Left e))
+     assert $ case l of
+       Left err -> length (show err) >= 0
+       Right _  -> de /= Strict
  
  t_utf8_err' :: B.ByteString -> Property
  t_utf8_err' bs = monadicIO . assert $ case E.decodeUtf8' bs of