module Lens.Micro.GHC.Internal
(
IsByteString(..),
unpackStrict,
unpackStrict8,
unpackLazy,
unpackLazy8,
fromStrict,
toStrict,
traversedStrictTree,
traversedStrictTree8,
traversedLazy,
traversedLazy8,
)
where
import Lens.Micro
import Lens.Micro.Internal
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Char8 as B8
import qualified Data.ByteString.Lazy.Char8 as BL8
import qualified Data.ByteString.Internal as BI
import qualified Data.ByteString.Unsafe as BU
import Data.Int
import Data.Word
import Data.Char
import Data.Monoid
import Foreign.Storable
import Foreign.Ptr
import Data.Bits
#if MIN_VERSION_base(4,8,0)
import Foreign.ForeignPtr
#else
import Foreign.ForeignPtr.Safe
#endif
import GHC.ForeignPtr (mallocPlainForeignPtrBytes)
#if !MIN_VERSION_bytestring(0,10,4)
import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
#endif
import GHC.IO (unsafeDupablePerformIO)
import GHC.Base (unsafeChr)
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative
#endif
class IsByteString t where
packedBytes :: Lens' [Word8] t
unpackedBytes :: Lens' t [Word8]
packedChars :: Lens' String t
unpackedChars :: Lens' t String
chars :: Traversal' t Char
instance IsByteString B.ByteString where
packedBytes f s = unpackStrict <$> f (B.pack s)
unpackedBytes f s = B.pack <$> f (unpackStrict s)
packedChars f s = unpackStrict8 <$> f (B8.pack s)
unpackedChars f s = B8.pack <$> f (unpackStrict8 s)
chars = traversedStrictTree8
instance IsByteString BL.ByteString where
packedBytes f s = unpackLazy <$> f (BL.pack s)
unpackedBytes f s = BL.pack <$> f (unpackLazy s)
packedChars f s = unpackLazy8 <$> f (BL8.pack s)
unpackedChars f s = BL8.pack <$> f (unpackLazy8 s)
chars = traversedLazy8
unpackStrict :: B.ByteString -> [Word8]
#if MIN_VERSION_bytestring(0,10,4)
unpackStrict = B.unpack
#else
unpackStrict (BI.PS fp off len) =
let p = unsafeForeignPtrToPtr fp
in go (p `plusPtr` off) (p `plusPtr` (off+len))
where
go !p !q | p == q = []
| otherwise = let !x = BI.inlinePerformIO $ do
x' <- peek p
touchForeignPtr fp
return x'
in x : go (p `plusPtr` 1) q
#endif
unpackStrict8 :: B.ByteString -> String
#if MIN_VERSION_bytestring(0,10,4)
unpackStrict8 = B8.unpack
#else
unpackStrict8 (BI.PS fp off len) =
let p = unsafeForeignPtrToPtr fp
in go (p `plusPtr` off) (p `plusPtr` (off+len))
where
go !p !q | p == q = []
| otherwise = let !x = BI.inlinePerformIO $ do
x' <- peek p
touchForeignPtr fp
return x'
in w2c x : go (p `plusPtr` 1) q
#endif
unpackLazy :: BL.ByteString -> [Word8]
unpackLazy = BL.unpack
unpackLazy8 :: BL.ByteString -> String
unpackLazy8 = BL8.unpack
fromStrict :: B.ByteString -> BL.ByteString
#if MIN_VERSION_bytestring(0,10,0)
fromStrict = BL.fromStrict
#else
fromStrict = \x -> BL.fromChunks [x]
#endif
toStrict :: BL.ByteString -> B.ByteString
#if MIN_VERSION_bytestring(0,10,0)
toStrict = BL.toStrict
#else
toStrict = B.concat . BL.toChunks
#endif
grain :: Int
grain = 32
traversedStrictTree :: Traversal' B.ByteString Word8
traversedStrictTree afb bs = unsafeCreate len <$> go 0 len
where
len = B.length bs
go !i !j
| i + grain < j, k <- i + shiftR (j i) 1 = (\l r q -> l q >> r q) <$> go i k <*> go k j
| otherwise = run i j
run !i !j
| i == j = pure (\_ -> return ())
| otherwise = let !x = BU.unsafeIndex bs i
in (\y ys q -> pokeByteOff q i y >> ys q) <$> afb x <*> run (i + 1) j
traversedStrictTree8 :: Traversal' B.ByteString Char
traversedStrictTree8 pafb bs = unsafeCreate len <$> go 0 len
where
len = B.length bs
go !i !j
| i + grain < j = let k = i + shiftR (j i) 1
in (\l r q -> l q >> r q) <$> go i k <*> go k j
| otherwise = run i j
run !i !j
| i == j = pure (\_ -> return ())
| otherwise = let !x = BU.unsafeIndex bs i
in (\y ys q -> pokeByteOff q i (c2w y) >> ys q)
<$> pafb (w2c x)
<*> run (i + 1) j
traversedLazy :: Traversal' BL.ByteString Word8
traversedLazy pafb = \lbs -> foldrChunks go (\_ -> pure BL.empty) lbs 0
where
go c fcs acc = BL.append . fromStrict
<$> traversedStrictTree pafb c
<*> fcs acc'
where
acc' :: Int64
!acc' = acc + fromIntegral (B.length c)
traversedLazy8 :: Traversal' BL.ByteString Char
traversedLazy8 pafb = \lbs -> foldrChunks go (\_ -> pure BL.empty) lbs 0
where
go c fcs acc = BL.append . fromStrict
<$> traversedStrictTree8 pafb c
<*> fcs acc'
where
acc' :: Int64
!acc' = acc + fromIntegral (B.length c)
unsafeCreate :: Int -> (Ptr Word8 -> IO ()) -> B.ByteString
unsafeCreate l f = unsafeDupablePerformIO (create l f)
create :: Int -> (Ptr Word8 -> IO ()) -> IO B.ByteString
create l f = do
fp <- mallocPlainForeignPtrBytes l
withForeignPtr fp $ \p -> f p
return $! BI.PS fp 0 l
foldrChunks :: (B.ByteString -> r -> r) -> r -> BL.ByteString -> r
#if MIN_VERSION_bytestring(0,10,0)
foldrChunks = BL.foldrChunks
#else
foldrChunks f z b = foldr f z (BL.toChunks b)
#endif
w2c :: Word8 -> Char
w2c = unsafeChr . fromIntegral
c2w :: Char -> Word8
c2w = fromIntegral . ord