1{-# LANGUAGE BangPatterns #-} 2{-# LANGUAGE CPP #-} 3{-# LANGUAGE MagicHash #-} 4module Data.ByteString.Base16.Internal 5( -- * worker loops 6 encodeLoop 7, decodeLoop 8, lenientLoop 9 -- * utils 10, c2w 11, aix 12, reChunk 13, unsafeShiftR 14, withBS 15, mkBS 16) where 17 18 19import Data.Bits ((.&.), (.|.)) 20import qualified Data.ByteString as B 21import Data.ByteString.Internal (ByteString(..)) 22import Data.Char (ord) 23 24import Foreign.ForeignPtr (ForeignPtr, withForeignPtr) 25import Foreign.Ptr (Ptr, minusPtr, plusPtr) 26import Foreign.Storable (Storable(poke, peek)) 27 28import GHC.Word (Word8(..)) 29import GHC.Exts (Int(I#), Addr#, indexWord8OffAddr#, word2Int#, uncheckedShiftRL#) 30 31#if __GLASGOW_HASKELL__ >= 702 32import System.IO.Unsafe (unsafeDupablePerformIO) 33#else 34import GHC.IO (unsafeDupablePerformIO) 35#endif 36 37 38-- ------------------------------------------------------------------ -- 39-- Loops 40 41encodeLoop 42 :: Ptr Word8 43 -> Ptr Word8 44 -> Ptr Word8 45 -> IO () 46encodeLoop !dptr !sptr !end = go dptr sptr 47 where 48 !hex = "0123456789abcdef"# 49 50 go !dst !src 51 | src == end = return () 52 | otherwise = do 53 !t <- peek src 54 55 poke dst (aix (unsafeShiftR t 4) hex) 56 poke (plusPtr dst 1) (aix (t .&. 0x0f) hex) 57 58 go (plusPtr dst 2) (plusPtr src 1) 59{-# INLINE encodeLoop #-} 60 61decodeLoop 62 :: ForeignPtr Word8 63 -> Ptr Word8 64 -> Ptr Word8 65 -> Ptr Word8 66 -> IO (Either String ByteString) 67decodeLoop !dfp !dptr !sptr !end = go dptr sptr 68 where 69 err !src = return . Left 70 $ "invalid character at offset: " 71 ++ show (src `minusPtr` sptr) 72 73 !lo = "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x01\x02\x03\x04\x05\x06\x07\x08\x09\xff\xff\xff\xff\xff\xff\xff\x0a\x0b\x0c\x0d\x0e\x0f\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x0b\x0c\x0d\x0e\x0f\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# 74 75 !hi = "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x10\x20\x30\x40\x50\x60\x70\x80\x90\xff\xff\xff\xff\xff\xff\xff\xa0\xb0\xc0\xd0\xe0\xf0\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xa0\xb0\xc0\xd0\xe0\xf0\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# 76 77 go !dst !src 78 | src == end = return (Right (mkBS dfp (dst `minusPtr` dptr))) 79 | otherwise = do 80 !x <- peek src 81 !y <- peek (plusPtr src 1) 82 83 let !a = aix x hi 84 !b = aix y lo 85 86 if a == 0xff 87 then err src 88 else 89 if b == 0xff 90 then err (plusPtr src 1) 91 else do 92 poke dst (a .|. b) 93 go (plusPtr dst 1) (plusPtr src 2) 94{-# INLINE decodeLoop #-} 95 96lenientLoop 97 :: ForeignPtr Word8 98 -> Ptr Word8 99 -> Ptr Word8 100 -> Ptr Word8 101 -> IO ByteString 102lenientLoop !dfp !dptr !sptr !end = goHi dptr sptr 0 103 where 104 !lo = "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x01\x02\x03\x04\x05\x06\x07\x08\x09\xff\xff\xff\xff\xff\xff\xff\x0a\x0b\x0c\x0d\x0e\x0f\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x0b\x0c\x0d\x0e\x0f\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# 105 106 !hi = "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x10\x20\x30\x40\x50\x60\x70\x80\x90\xff\xff\xff\xff\xff\xff\xff\xa0\xb0\xc0\xd0\xe0\xf0\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xa0\xb0\xc0\xd0\xe0\xf0\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# 107 108 goHi !dst !src !n 109 | src == end = return (mkBS dfp n) 110 | otherwise = do 111 !x <- peek src 112 113 let !a = aix x hi 114 115 if a == 0xff 116 then goHi dst (plusPtr src 1) n 117 else goLo dst (plusPtr src 1) a n 118 119 goLo !dst !src !a !n 120 | src == end = return (mkBS dfp n) 121 | otherwise = do 122 !y <- peek src 123 124 let !b = aix y lo 125 126 if b == 0xff 127 then goLo dst (plusPtr src 1) a n 128 else do 129 poke dst (a .|. b) 130 goHi (plusPtr dst 1) (plusPtr src 1) (n + 1) 131{-# INLINE lenientLoop #-} 132 133 134-- ------------------------------------------------------------------ -- 135-- Utils 136 137aix :: Word8 -> Addr# -> Word8 138aix (W8# w) table = W8# (indexWord8OffAddr# table (word2Int# w)) 139{-# INLINE aix #-} 140 141-- | Form a list of chunks, and rechunk the list of bytestrings 142-- into length multiples of 2 143-- 144reChunk :: [ByteString] -> [ByteString] 145reChunk [] = [] 146reChunk (c:cs) = case B.length c `divMod` 2 of 147 (_, 0) -> c : reChunk cs 148 (n, _) -> case B.splitAt (n * 2) c of 149 ~(m, q) -> m : cont_ q cs 150 where 151 cont_ q [] = [q] 152 cont_ q (a:as) = case B.splitAt 1 a of 153 ~(x, y) -> let q' = B.append q x 154 in if B.length q' == 2 155 then 156 let as' = if B.null y then as else y:as 157 in q' : reChunk as' 158 else cont_ q' as 159 160unsafeShiftR :: Word8 -> Int -> Word8 161unsafeShiftR (W8# x#) (I# i#) = W8# (x# `uncheckedShiftRL#` i#) 162{-# INLINE unsafeShiftR #-} 163 164c2w :: Char -> Word8 165c2w = fromIntegral . ord 166{-# INLINE c2w #-} 167 168mkBS :: ForeignPtr Word8 -> Int -> ByteString 169#if MIN_VERSION_bytestring(0,11,0) 170mkBS dfp n = BS dfp n 171#else 172mkBS dfp n = PS dfp 0 n 173#endif 174{-# INLINE mkBS #-} 175 176withBS :: ByteString -> (Ptr Word8 -> Int -> IO a) -> a 177#if MIN_VERSION_bytestring(0,11,0) 178withBS (BS !sfp !slen) f = unsafeDupablePerformIO $ 179 withForeignPtr sfp $ \p -> f p slen 180#else 181withBS (PS !sfp !soff !slen) f = unsafeDupablePerformIO $ 182 withForeignPtr sfp $ \p -> f (plusPtr p soff) slen 183#endif 184{-# INLINE withBS #-} 185