module Ptr.Poking where

import qualified Data.ByteString.Internal as B
import qualified Data.List as List
import qualified Data.Vector as F
import qualified Data.Vector.Generic as GenericVector
import qualified Ptr.IO as A
import qualified Ptr.List as List
import qualified Ptr.Poke as C
import qualified Ptr.PokeAndPeek as D
import qualified Ptr.PokeIO as E
import Ptr.Prelude hiding (length)

-- |
-- An efficiently composable unmaterialised specification of how to populate a pointer.
--
-- Once composed it can be materialized into a specific data-structure like ByteString or
-- to directly populate a pointer in some low-level API.
data Poking
  = -- |
    --  * Amount of bytes the encoded data will occupy.
    --  * Exception-free action, which populates the pointer to the encoded data.
    Poking !Int (Ptr Word8 -> IO ())

instance Semigroup Poking where
  {-# INLINEABLE (<>) #-}
  <> :: Poking -> Poking -> Poking
(<>) (Poking Int
space1 Ptr Word8 -> IO ()
action1) (Poking Int
space2 Ptr Word8 -> IO ()
action2) =
    Int -> (Ptr Word8 -> IO ()) -> Poking
Poking (Int
space1 forall a. Num a => a -> a -> a
+ Int
space2) Ptr Word8 -> IO ()
action
    where
      action :: Ptr Word8 -> IO ()
action =
        if Int
space1 forall a. Ord a => a -> a -> Bool
< Int
2048 Bool -> Bool -> Bool
|| Int
space2 forall a. Ord a => a -> a -> Bool
< Int
2048
          then Int
-> (Ptr Word8 -> IO ())
-> (Ptr Word8 -> IO ())
-> Ptr Word8
-> IO ()
E.sequentially Int
space1 Ptr Word8 -> IO ()
action1 Ptr Word8 -> IO ()
action2
          else Int
-> (Ptr Word8 -> IO ())
-> (Ptr Word8 -> IO ())
-> Ptr Word8
-> IO ()
E.concurrently Int
space1 Ptr Word8 -> IO ()
action1 Ptr Word8 -> IO ()
action2

instance Monoid Poking where
  {-# INLINE mempty #-}
  mempty :: Poking
mempty =
    Int -> (Ptr Word8 -> IO ()) -> Poking
Poking Int
0 (forall a b. a -> b -> a
const (forall (f :: * -> *) a. Applicative f => a -> f a
pure ()))
  {-# INLINE mappend #-}
  mappend :: Poking -> Poking -> Poking
mappend =
    forall a. Semigroup a => a -> a -> a
(<>)

instance IsString Poking where
  fromString :: String -> Poking
fromString String
string = Int -> (Ptr Word8 -> IO ()) -> Poking
Poking (forall (t :: * -> *) a. Foldable t => t a -> Int
List.length String
string) Ptr Word8 -> IO ()
io
    where
      io :: Ptr Word8 -> IO ()
io Ptr Word8
ptr = forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m ()
foldM_ forall {b}. Ptr Word8 -> Char -> IO (Ptr b)
step Ptr Word8
ptr String
string
        where
          step :: Ptr Word8 -> Char -> IO (Ptr b)
step Ptr Word8
ptr Char
char = Ptr Word8 -> Word8 -> IO ()
A.pokeWord8 Ptr Word8
ptr (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
char)) forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
ptr Int
1

{-# INLINE null #-}
null :: Poking -> Bool
null :: Poking -> Bool
null =
  (forall a. Eq a => a -> a -> Bool
== Int
0) forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Poking -> Int
length

{-# INLINE length #-}
length :: Poking -> Int
length :: Poking -> Int
length (Poking Int
size Ptr Word8 -> IO ()
_) =
  Int
size

{-# INLINE word8 #-}
word8 :: Word8 -> Poking
word8 :: Word8 -> Poking
word8 Word8
x =
  Int -> (Ptr Word8 -> IO ()) -> Poking
Poking Int
1 (forall a b c. (a -> b -> c) -> b -> a -> c
flip Ptr Word8 -> Word8 -> IO ()
A.pokeWord8 Word8
x)

{-# INLINE leWord16 #-}
leWord16 :: Word16 -> Poking
leWord16 :: Word16 -> Poking
leWord16 Word16
x =
  Int -> (Ptr Word8 -> IO ()) -> Poking
Poking Int
2 (forall a b c. (a -> b -> c) -> b -> a -> c
flip Ptr Word8 -> Word16 -> IO ()
A.pokeLEWord16 Word16
x)

{-# INLINE leWord32 #-}
leWord32 :: Word32 -> Poking
leWord32 :: Word32 -> Poking
leWord32 Word32
x =
  Int -> (Ptr Word8 -> IO ()) -> Poking
Poking Int
4 (forall a b c. (a -> b -> c) -> b -> a -> c
flip Ptr Word8 -> Word32 -> IO ()
A.pokeLEWord32 Word32
x)

{-# INLINE leWord64 #-}
leWord64 :: Word64 -> Poking
leWord64 :: Word64 -> Poking
leWord64 Word64
x =
  Int -> (Ptr Word8 -> IO ()) -> Poking
Poking Int
8 (forall a b c. (a -> b -> c) -> b -> a -> c
flip Ptr Word8 -> Word64 -> IO ()
A.pokeLEWord64 Word64
x)

{-# INLINE beWord16 #-}
beWord16 :: Word16 -> Poking
beWord16 :: Word16 -> Poking
beWord16 Word16
x =
  Int -> (Ptr Word8 -> IO ()) -> Poking
Poking Int
2 (forall a b c. (a -> b -> c) -> b -> a -> c
flip Ptr Word8 -> Word16 -> IO ()
A.pokeBEWord16 Word16
x)

{-# INLINE beWord32 #-}
beWord32 :: Word32 -> Poking
beWord32 :: Word32 -> Poking
beWord32 Word32
x =
  Int -> (Ptr Word8 -> IO ()) -> Poking
Poking Int
4 (forall a b c. (a -> b -> c) -> b -> a -> c
flip Ptr Word8 -> Word32 -> IO ()
A.pokeBEWord32 Word32
x)

{-# INLINE beWord64 #-}
beWord64 :: Word64 -> Poking
beWord64 :: Word64 -> Poking
beWord64 Word64
x =
  Int -> (Ptr Word8 -> IO ()) -> Poking
Poking Int
8 (forall a b c. (a -> b -> c) -> b -> a -> c
flip Ptr Word8 -> Word64 -> IO ()
A.pokeBEWord64 Word64
x)

{-# INLINE bytes #-}
bytes :: ByteString -> Poking
bytes :: ByteString -> Poking
bytes (B.PS ForeignPtr Word8
bytesFPtr Int
offset Int
length) =
  Int -> (Ptr Word8 -> IO ()) -> Poking
Poking Int
length (\Ptr Word8
ptr -> forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
bytesFPtr (\Ptr Word8
bytesPtr -> Ptr Word8 -> Ptr Word8 -> Int -> IO ()
B.memcpy Ptr Word8
ptr (forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
bytesPtr Int
offset) Int
length))

{-# INLINE poke #-}
poke :: C.Poke input -> input -> Poking
poke :: forall input. Poke input -> input -> Poking
poke (C.Poke Int
space Ptr Word8 -> input -> IO ()
poke) input
input =
  Int -> (Ptr Word8 -> IO ()) -> Poking
Poking Int
space (\Ptr Word8
ptr -> Ptr Word8 -> input -> IO ()
poke Ptr Word8
ptr input
input)

{-# INLINE pokeAndPeek #-}
pokeAndPeek :: D.PokeAndPeek input output -> input -> Poking
pokeAndPeek :: forall input output. PokeAndPeek input output -> input -> Poking
pokeAndPeek (D.PokeAndPeek Int
space Ptr Word8 -> input -> IO ()
poke Ptr Word8 -> IO output
_) input
input =
  Int -> (Ptr Word8 -> IO ()) -> Poking
Poking Int
space (\Ptr Word8
ptr -> Ptr Word8 -> input -> IO ()
poke Ptr Word8
ptr input
input)

-- | Unsigned ASCII integral
{-# INLINE asciiIntegral #-}
asciiIntegral :: (Integral a) => a -> Poking
asciiIntegral :: forall a. Integral a => a -> Poking
asciiIntegral = \case
  a
0 -> Word8 -> Poking
word8 Word8
48
  a
x ->
    let reverseDigits :: [a]
reverseDigits = forall a. Integral a => a -> a -> [a]
List.reverseDigits a
10 a
x
        size :: Int
size = forall (t :: * -> *) a. Foldable t => t a -> Int
List.length [a]
reverseDigits
        action :: Ptr Word8 -> IO ()
action = forall a. Integral a => Int -> [a] -> Ptr Word8 -> IO ()
E.reverseAsciiDigits (forall a. Enum a => a -> a
pred Int
size) [a]
reverseDigits
     in Int -> (Ptr Word8 -> IO ()) -> Poking
Poking Int
size Ptr Word8 -> IO ()
action

{-# INLINE asciiChar #-}
asciiChar :: Char -> Poking
asciiChar :: Char -> Poking
asciiChar =
  Word8 -> Poking
word8 forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Char -> Int
ord

{-# INLINEABLE asciiPaddedAndTrimmedIntegral #-}
asciiPaddedAndTrimmedIntegral :: Integral a => Int -> a -> Poking
asciiPaddedAndTrimmedIntegral :: forall a. Integral a => Int -> a -> Poking
asciiPaddedAndTrimmedIntegral !Int
length !a
integral =
  if Int
length forall a. Ord a => a -> a -> Bool
> Int
0
    then
      if a
integral forall a. Ord a => a -> a -> Bool
>= a
0
        then case forall a. Integral a => a -> a -> (a, a)
quotRem a
integral a
10 of
          (a
quot, a
rem) ->
            forall a. Integral a => Int -> a -> Poking
asciiPaddedAndTrimmedIntegral (forall a. Enum a => a -> a
pred Int
length) a
quot
              forall a. Semigroup a => a -> a -> a
<> Word8 -> Poking
word8 (Word8
48 forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral a
rem)
        else forall a b. (Semigroup a, Integral b) => b -> a -> a
stimes Int
length (Word8 -> Poking
word8 Word8
48)
    else forall a. Monoid a => a
mempty

{-# INLINEABLE asciiUtcTimeInIso8601 #-}
{-
2017-02-01T05:03:58Z
-}
asciiUtcTimeInIso8601 :: UTCTime -> Poking
asciiUtcTimeInIso8601 :: UTCTime -> Poking
asciiUtcTimeInIso8601 UTCTime
utcTime =
  forall a. Integral a => Int -> a -> Poking
asciiPaddedAndTrimmedIntegral Int
4 Year
year forall a. Semigroup a => a -> a -> a
<> Word8 -> Poking
word8 Word8
45
    forall a. Semigroup a => a -> a -> a
<> forall a. Integral a => Int -> a -> Poking
asciiPaddedAndTrimmedIntegral Int
2 Int
month
    forall a. Semigroup a => a -> a -> a
<> Word8 -> Poking
word8 Word8
45
    forall a. Semigroup a => a -> a -> a
<> forall a. Integral a => Int -> a -> Poking
asciiPaddedAndTrimmedIntegral Int
2 Int
day
    forall a. Semigroup a => a -> a -> a
<> Word8 -> Poking
word8 Word8
84
    forall a. Semigroup a => a -> a -> a
<> forall a. Integral a => Int -> a -> Poking
asciiPaddedAndTrimmedIntegral Int
2 Int
hour
    forall a. Semigroup a => a -> a -> a
<> Word8 -> Poking
word8 Word8
58
    forall a. Semigroup a => a -> a -> a
<> forall a. Integral a => Int -> a -> Poking
asciiPaddedAndTrimmedIntegral Int
2 Int
minute
    forall a. Semigroup a => a -> a -> a
<> Word8 -> Poking
word8 Word8
58
    forall a. Semigroup a => a -> a -> a
<> forall a. Integral a => Int -> a -> Poking
asciiPaddedAndTrimmedIntegral Int
2 (forall a b. (RealFrac a, Integral b) => a -> b
round Pico
second)
    forall a. Semigroup a => a -> a -> a
<> Word8 -> Poking
word8 Word8
90
  where
    LocalTime Day
date (TimeOfDay Int
hour Int
minute Pico
second) = TimeZone -> UTCTime -> LocalTime
utcToLocalTime TimeZone
utc UTCTime
utcTime
    (Year
year, Int
month, Int
day) = Day -> (Year, Int, Int)
toGregorian Day
date

{-# INLINE list #-}
list :: (element -> Poking) -> [element] -> Poking
list :: forall element. (element -> Poking) -> [element] -> Poking
list element -> Poking
element =
  Poking -> [element] -> Poking
loop forall a. Monoid a => a
mempty
  where
    loop :: Poking -> [element] -> Poking
loop Poking
state =
      \case
        element
head : [element]
tail -> Poking -> [element] -> Poking
loop (Poking
state forall a. Semigroup a => a -> a -> a
<> Word8 -> Poking
word8 Word8
1 forall a. Semigroup a => a -> a -> a
<> element -> Poking
element element
head) [element]
tail
        [element]
_ -> Poking
state forall a. Semigroup a => a -> a -> a
<> Word8 -> Poking
word8 Word8
0

{-# INLINEABLE vector #-}
vector :: GenericVector.Vector vector element => (element -> Poking) -> vector element -> Poking
vector :: forall (vector :: * -> *) element.
Vector vector element =>
(element -> Poking) -> vector element -> Poking
vector element -> Poking
element vector element
vectorValue =
  Int -> (Ptr Word8 -> IO ()) -> Poking
Poking Int
byteSize Ptr Word8 -> IO ()
io
  where
    byteSize :: Int
byteSize =
      forall (v :: * -> *) b a.
Vector v b =>
(a -> b -> a) -> a -> v b -> a
GenericVector.foldl' Int -> element -> Int
step Int
0 vector element
vectorValue
      where
        step :: Int -> element -> Int
step !Int
byteSize element
elementValue =
          case element -> Poking
element element
elementValue of
            Poking Int
elementByteSize Ptr Word8 -> IO ()
_ -> Int
byteSize forall a. Num a => a -> a -> a
+ Int
elementByteSize
    io :: Ptr Word8 -> IO ()
io Ptr Word8
ptr =
      forall (m :: * -> *) (v :: * -> *) b a.
(Monad m, Vector v b) =>
(a -> b -> m a) -> a -> v b -> m ()
GenericVector.foldM'_ Ptr Word8 -> element -> IO (Ptr Word8)
step Ptr Word8
ptr vector element
vectorValue
      where
        step :: Ptr Word8 -> element -> IO (Ptr Word8)
step Ptr Word8
ptr element
elementValue =
          case element -> Poking
element element
elementValue of
            Poking Int
elementByteSize Ptr Word8 -> IO ()
elementIO -> do
              Ptr Word8 -> IO ()
elementIO Ptr Word8
ptr
              forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
ptr Int
elementByteSize)

{-# INLINEABLE intercalateVector #-}
intercalateVector :: GenericVector.Vector vector element => (element -> Poking) -> Poking -> vector element -> Poking
intercalateVector :: forall (vector :: * -> *) element.
Vector vector element =>
(element -> Poking) -> Poking -> vector element -> Poking
intercalateVector element -> Poking
element (Poking Int
separatorLength Ptr Word8 -> IO ()
separatorIo) vector element
vectorValue = Int -> (Ptr Word8 -> IO ()) -> Poking
Poking Int
length Ptr Word8 -> IO ()
io
  where
    length :: Int
length = forall (v :: * -> *) b a.
Vector v b =>
(a -> b -> a) -> a -> v b -> a
GenericVector.foldl' Int -> element -> Int
step Int
0 vector element
vectorValue forall a. Num a => a -> a -> a
+ ((forall (v :: * -> *) a. Vector v a => v a -> Int
GenericVector.length vector element
vectorValue forall a. Num a => a -> a -> a
- Int
1) forall a. Num a => a -> a -> a
* Int
separatorLength)
      where
        step :: Int -> element -> Int
step Int
length element
elementValue = case element -> Poking
element element
elementValue of
          Poking Int
elementLength Ptr Word8 -> IO ()
_ -> Int
length forall a. Num a => a -> a -> a
+ Int
elementLength
    indexIsLast :: Int -> Bool
indexIsLast =
      let lastIndex :: Int
lastIndex = forall a. Enum a => a -> a
pred (forall (v :: * -> *) a. Vector v a => v a -> Int
GenericVector.length vector element
vectorValue)
       in (forall a. Eq a => a -> a -> Bool
== Int
lastIndex)
    io :: Ptr Word8 -> IO ()
io Ptr Word8
ptr = forall (m :: * -> *) (v :: * -> *) b a.
(Monad m, Vector v b) =>
(a -> Int -> b -> m a) -> a -> v b -> m ()
GenericVector.ifoldM'_ Ptr Word8 -> Int -> element -> IO (Ptr Word8)
step Ptr Word8
ptr vector element
vectorValue
      where
        step :: Ptr Word8 -> Int -> element -> IO (Ptr Word8)
step Ptr Word8
ptr Int
index element
elementValue = case element -> Poking
element element
elementValue of
          Poking Int
elementLength Ptr Word8 -> IO ()
elementIo ->
            if Int -> Bool
indexIsLast Int
index
              then Ptr Word8 -> IO ()
elementIo Ptr Word8
ptr forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Ptr Word8
ptr
              else
                let ptrAfterElement :: Ptr Word8
ptrAfterElement = forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
ptr Int
elementLength
                 in Ptr Word8 -> IO ()
elementIo Ptr Word8
ptr forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Ptr Word8 -> IO ()
separatorIo Ptr Word8
ptrAfterElement forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
ptrAfterElement Int
separatorLength