{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE Trustworthy #-}


{- |
Module      :  Lens.Micro.GHC.Internal
Copyright   :  (C) 2013-2016 Edward Kmett, 2015-2016 Artyom Kazak, 2018 Monadfix
License     :  BSD-style (see the file LICENSE)
-}
module Lens.Micro.GHC.Internal
(
  IsByteString(..),
  -- * Unpacking bytestrings
  unpackStrict,
  unpackStrict8,
  unpackLazy,
  unpackLazy8,
  -- * Converting bytestrings between strict and lazy
  fromStrict,
  toStrict,
  -- * Traversing bytestrings
  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
  {- |
Treat a list of bytes as a strict or lazy @ByteString@.
  -}
  packedBytes :: Lens' [Word8] t
  {- |
Treat a strict or lazy @ByteString@ as a list of bytes.
  -}
  unpackedBytes :: Lens' t [Word8]
  {- |
Treat a 'String' as a strict or lazy @ByteString@. (Note that it will garble characters above 0xFF, same as 'B8.pack' does.)
  -}
  packedChars :: Lens' String t
  {- |
Treat a strict or lazy @ByteString@ as a 'String'. (Just as 'packedChars', it will garble characters above 0xFF.)
  -}
  unpackedChars :: Lens' t String
  {- |
Traverse characters in a strict or lazy @ByteString@ (to traverse bytes instead of characters, use 'each').
  -}
  chars :: Traversal' t Char

-- When writing back to the 'ByteString' it is assumed that every 'Char'
-- lies between @'\x00'@ and @'\xff'@.

instance IsByteString B.ByteString where
  packedBytes :: Lens' [Word8] ByteString
packedBytes ByteString -> f ByteString
f [Word8]
s = ByteString -> [Word8]
unpackStrict forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> f ByteString
f ([Word8] -> ByteString
B.pack [Word8]
s)
  {-# INLINE packedBytes #-}
  unpackedBytes :: Lens' ByteString [Word8]
unpackedBytes [Word8] -> f [Word8]
f ByteString
s = [Word8] -> ByteString
B.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Word8] -> f [Word8]
f (ByteString -> [Word8]
unpackStrict ByteString
s)
  {-# INLINE unpackedBytes #-}
  packedChars :: Lens' String ByteString
packedChars ByteString -> f ByteString
f String
s = ByteString -> String
unpackStrict8 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> f ByteString
f (String -> ByteString
B8.pack String
s)
  {-# INLINE packedChars #-}
  unpackedChars :: Lens' ByteString String
unpackedChars String -> f String
f ByteString
s = String -> ByteString
B8.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> f String
f (ByteString -> String
unpackStrict8 ByteString
s)
  {-# INLINE unpackedChars #-}
  chars :: Traversal' ByteString Char
chars = Traversal' ByteString Char
traversedStrictTree8
  {-# INLINE chars #-}

instance IsByteString BL.ByteString where
  packedBytes :: Lens' [Word8] ByteString
packedBytes ByteString -> f ByteString
f [Word8]
s = ByteString -> [Word8]
unpackLazy forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> f ByteString
f ([Word8] -> ByteString
BL.pack [Word8]
s)
  {-# INLINE packedBytes #-}
  unpackedBytes :: Lens' ByteString [Word8]
unpackedBytes [Word8] -> f [Word8]
f ByteString
s = [Word8] -> ByteString
BL.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Word8] -> f [Word8]
f (ByteString -> [Word8]
unpackLazy ByteString
s)
  {-# INLINE unpackedBytes #-}
  packedChars :: Lens' String ByteString
packedChars ByteString -> f ByteString
f String
s = ByteString -> String
unpackLazy8 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> f ByteString
f (String -> ByteString
BL8.pack String
s)
  {-# INLINE packedChars #-}
  unpackedChars :: Lens' ByteString String
unpackedChars String -> f String
f ByteString
s = String -> ByteString
BL8.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> f String
f (ByteString -> String
unpackLazy8 ByteString
s)
  {-# INLINE unpackedChars #-}
  chars :: Traversal' ByteString Char
chars = Traversal' ByteString Char
traversedLazy8
  {-# INLINE chars #-}

-- unpacking

unpackStrict :: B.ByteString -> [Word8]
#if MIN_VERSION_bytestring(0,10,4)
unpackStrict :: ByteString -> [Word8]
unpackStrict = ByteString -> [Word8]
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
{-# INLINE unpackStrict #-}

unpackStrict8 :: B.ByteString -> String
#if MIN_VERSION_bytestring(0,10,4)
unpackStrict8 :: ByteString -> String
unpackStrict8 = ByteString -> String
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
{-# INLINE unpackStrict8 #-}

unpackLazy :: BL.ByteString -> [Word8]
unpackLazy :: ByteString -> [Word8]
unpackLazy = ByteString -> [Word8]
BL.unpack
{-# INLINE unpackLazy #-}

unpackLazy8 :: BL.ByteString -> String
unpackLazy8 :: ByteString -> String
unpackLazy8 = ByteString -> String
BL8.unpack
{-# INLINE unpackLazy8 #-}

-- converting between strict and lazy

fromStrict :: B.ByteString -> BL.ByteString
#if MIN_VERSION_bytestring(0,10,0)
fromStrict :: ByteString -> ByteString
fromStrict = ByteString -> ByteString
BL.fromStrict
#else
fromStrict = \x -> BL.fromChunks [x]
#endif
{-# INLINE fromStrict #-}

toStrict :: BL.ByteString -> B.ByteString
#if MIN_VERSION_bytestring(0,10,0)
toStrict :: ByteString -> ByteString
toStrict = ByteString -> ByteString
BL.toStrict
#else
toStrict = B.concat . BL.toChunks
#endif
{-# INLINE toStrict #-}

-- traversing

grain :: Int
grain :: Int
grain = Int
32
{-# INLINE grain #-}

traversedStrictTree :: Traversal' B.ByteString Word8
traversedStrictTree :: Traversal' ByteString Word8
traversedStrictTree Word8 -> f Word8
afb ByteString
bs = Int -> (Ptr Word8 -> IO ()) -> ByteString
unsafeCreate Int
len forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {b}. Int -> Int -> f (Ptr b -> IO ())
go Int
0 Int
len
 where
   len :: Int
len = ByteString -> Int
B.length ByteString
bs
   go :: Int -> Int -> f (Ptr b -> IO ())
go !Int
i !Int
j
     | Int
i forall a. Num a => a -> a -> a
+ Int
grain forall a. Ord a => a -> a -> Bool
< Int
j, Int
k <- Int
i forall a. Num a => a -> a -> a
+ forall a. Bits a => a -> Int -> a
shiftR (Int
j forall a. Num a => a -> a -> a
- Int
i) Int
1 = (\Ptr b -> IO ()
l Ptr b -> IO ()
r Ptr b
q -> Ptr b -> IO ()
l Ptr b
q forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Ptr b -> IO ()
r Ptr b
q) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Int -> f (Ptr b -> IO ())
go Int
i Int
k forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> Int -> f (Ptr b -> IO ())
go Int
k Int
j
     | Bool
otherwise = forall {b}. Int -> Int -> f (Ptr b -> IO ())
run Int
i Int
j
   run :: Int -> Int -> f (Ptr b -> IO ())
run !Int
i !Int
j
     | Int
i forall a. Eq a => a -> a -> Bool
== Int
j    = forall (f :: * -> *) a. Applicative f => a -> f a
pure (\Ptr b
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ())
     | Bool
otherwise = let !x :: Word8
x = ByteString -> Int -> Word8
BU.unsafeIndex ByteString
bs Int
i
                   in (\Word8
y Ptr b -> IO ()
ys Ptr b
q -> forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr b
q Int
i Word8
y forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Ptr b -> IO ()
ys Ptr b
q) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Word8 -> f Word8
afb Word8
x forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> Int -> f (Ptr b -> IO ())
run (Int
i forall a. Num a => a -> a -> a
+ Int
1) Int
j
{-# INLINE [0] traversedStrictTree #-}

{-# RULES
"bytes -> map"
  traversedStrictTree = sets B.map :: ASetter' B.ByteString Word8;
"bytes -> foldr"
  traversedStrictTree = foldring B.foldr :: Getting (Endo r) B.ByteString Word8;
  #-}

traversedStrictTree8 :: Traversal' B.ByteString Char
traversedStrictTree8 :: Traversal' ByteString Char
traversedStrictTree8 Char -> f Char
pafb ByteString
bs = Int -> (Ptr Word8 -> IO ()) -> ByteString
unsafeCreate Int
len forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {b}. Int -> Int -> f (Ptr b -> IO ())
go Int
0 Int
len
 where
   len :: Int
len = ByteString -> Int
B.length ByteString
bs
   go :: Int -> Int -> f (Ptr b -> IO ())
go !Int
i !Int
j
     | Int
i forall a. Num a => a -> a -> a
+ Int
grain forall a. Ord a => a -> a -> Bool
< Int
j    = let k :: Int
k = Int
i forall a. Num a => a -> a -> a
+ forall a. Bits a => a -> Int -> a
shiftR (Int
j forall a. Num a => a -> a -> a
- Int
i) Int
1
                          in (\Ptr b -> IO ()
l Ptr b -> IO ()
r Ptr b
q -> Ptr b -> IO ()
l Ptr b
q forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Ptr b -> IO ()
r Ptr b
q) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Int -> f (Ptr b -> IO ())
go Int
i Int
k forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> Int -> f (Ptr b -> IO ())
go Int
k Int
j
     | Bool
otherwise        = forall {b}. Int -> Int -> f (Ptr b -> IO ())
run Int
i Int
j
   run :: Int -> Int -> f (Ptr b -> IO ())
run !Int
i !Int
j
     | Int
i forall a. Eq a => a -> a -> Bool
== Int
j           = forall (f :: * -> *) a. Applicative f => a -> f a
pure (\Ptr b
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ())
     | Bool
otherwise        = let !x :: Word8
x = ByteString -> Int -> Word8
BU.unsafeIndex ByteString
bs Int
i
                          in (\Char
y Ptr b -> IO ()
ys Ptr b
q -> forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr b
q Int
i (Char -> Word8
c2w Char
y) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Ptr b -> IO ()
ys Ptr b
q)
                         forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> f Char
pafb (Word8 -> Char
w2c Word8
x)
                         forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> Int -> f (Ptr b -> IO ())
run (Int
i forall a. Num a => a -> a -> a
+ Int
1) Int
j
{-# INLINE [0] traversedStrictTree8 #-}

{-# RULES
"chars -> map"
  traversedStrictTree8 = sets B8.map :: ASetter' B.ByteString Char;
"chars -> foldr"
  traversedStrictTree8 = foldring B8.foldr :: Getting (Endo r) B.ByteString Char;
  #-}

traversedLazy :: Traversal' BL.ByteString Word8
traversedLazy :: Traversal' ByteString Word8
traversedLazy Word8 -> f Word8
pafb = \ByteString
lbs -> forall r. (ByteString -> r -> r) -> r -> ByteString -> r
foldrChunks ByteString -> (Int64 -> f ByteString) -> Int64 -> f ByteString
go (\Int64
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
BL.empty) ByteString
lbs Int64
0
  where
  go :: ByteString -> (Int64 -> f ByteString) -> Int64 -> f ByteString
go ByteString
c Int64 -> f ByteString
fcs Int64
acc = ByteString -> ByteString -> ByteString
BL.append forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
fromStrict
             forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Traversal' ByteString Word8
traversedStrictTree Word8 -> f Word8
pafb ByteString
c
             forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int64 -> f ByteString
fcs Int64
acc'
    where
    acc' :: Int64
    !acc' :: Int64
acc' = Int64
acc forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
B.length ByteString
c)
{-# INLINE [1] traversedLazy #-}

{-# RULES
"sets lazy bytestring"
  traversedLazy = sets BL.map :: ASetter' BL.ByteString Word8;
"gets lazy bytestring"
  traversedLazy = foldring BL.foldr :: Getting (Endo r) BL.ByteString Word8;
  #-}

traversedLazy8 :: Traversal' BL.ByteString Char
traversedLazy8 :: Traversal' ByteString Char
traversedLazy8 Char -> f Char
pafb = \ByteString
lbs -> forall r. (ByteString -> r -> r) -> r -> ByteString -> r
foldrChunks ByteString -> (Int64 -> f ByteString) -> Int64 -> f ByteString
go (\Int64
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
BL.empty) ByteString
lbs Int64
0
  where
  go :: ByteString -> (Int64 -> f ByteString) -> Int64 -> f ByteString
go ByteString
c Int64 -> f ByteString
fcs Int64
acc = ByteString -> ByteString -> ByteString
BL.append forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
fromStrict
             forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Traversal' ByteString Char
traversedStrictTree8 Char -> f Char
pafb ByteString
c
             forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int64 -> f ByteString
fcs Int64
acc'
    where
    acc' :: Int64
    !acc' :: Int64
acc' = Int64
acc forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
B.length ByteString
c)
{-# INLINE [1] traversedLazy8 #-}

{-# RULES
"sets lazy bytestring"
  traversedLazy8 = sets BL8.map :: ASetter' BL8.ByteString Char;
"gets lazy bytestring"
  traversedLazy8 = foldring BL8.foldr :: Getting (Endo r) BL8.ByteString Char;
  #-}

-- A way of creating ByteStrings outside the IO monad. The @Int@
-- argument gives the final size of the ByteString. Unlike
-- 'createAndTrim' the ByteString is not reallocated if the final size
-- is less than the estimated size.
unsafeCreate :: Int -> (Ptr Word8 -> IO ()) -> B.ByteString
unsafeCreate :: Int -> (Ptr Word8 -> IO ()) -> ByteString
unsafeCreate Int
l Ptr Word8 -> IO ()
f = forall a. IO a -> a
unsafeDupablePerformIO (Int -> (Ptr Word8 -> IO ()) -> IO ByteString
create Int
l Ptr Word8 -> IO ()
f)
{-# INLINE unsafeCreate #-}

-- Create ByteString of size @l@ and use action @f@ to fill its contents.
create :: Int -> (Ptr Word8 -> IO ()) -> IO B.ByteString
create :: Int -> (Ptr Word8 -> IO ()) -> IO ByteString
create Int
l Ptr Word8 -> IO ()
f = do
    ForeignPtr Word8
fp <- forall a. Int -> IO (ForeignPtr a)
mallocPlainForeignPtrBytes Int
l
    forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
fp forall a b. (a -> b) -> a -> b
$ \Ptr Word8
p -> Ptr Word8 -> IO ()
f Ptr Word8
p
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! ForeignPtr Word8 -> Int -> Int -> ByteString
BI.PS ForeignPtr Word8
fp Int
0 Int
l
{-# INLINE create #-}

foldrChunks :: (B.ByteString -> r -> r) -> r -> BL.ByteString -> r
#if MIN_VERSION_bytestring(0,10,0)
foldrChunks :: forall r. (ByteString -> r -> r) -> r -> ByteString -> r
foldrChunks = forall r. (ByteString -> r -> r) -> r -> ByteString -> r
BL.foldrChunks
#else
foldrChunks f z b = foldr f z (BL.toChunks b)
#endif
{-# INLINE foldrChunks #-}

w2c :: Word8 -> Char
w2c :: Word8 -> Char
w2c = Int -> Char
unsafeChr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral
{-# INLINE w2c #-}

c2w :: Char -> Word8
c2w :: Char -> Word8
c2w = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
ord
{-# INLINE c2w #-}