{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE BlockArguments, LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables, RankNTypes, TypeApplications #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}
{-# LANGUAGE PatternSynonyms, ViewPatterns #-}
{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}

module Foreign.Storable.PeekPoke.Internal (

	-- * Sizable, Peek and Poke

	Sizable(..), Peek(..), peekMaybe, Poke(..),

	-- * Peekable, WithPoked and Pokable

	Peekable, peekArray',
	WithPoked(..), PtrS(..), ptrS, withPtrS, withPokedMaybe',
	Pokable, withPoked, withPokedMaybe,

	-- * Storable' and NullPtr

	Storable', pattern NullPtr ) where

import Foreign.Ptr
import Foreign.Marshal.Alloc
import Foreign.Storable
import Data.TypeLevel.Maybe qualified as TMaybe
import Data.TypeLevel.ParMaybe qualified as TPMaybe

class Sizable a where sizeOf' :: Int; alignment' :: Int
class Peek a where peek' :: Ptr a -> IO a
class Poke a where poke' :: Ptr a -> a -> IO ()

class (Sizable a, Peek a) => Peekable a
instance (Sizable a, Peek a) => Peekable a

class (Sizable a, Poke a, WithPoked a) => Pokable a
instance (Sizable a, Poke a) => Pokable a

class (Peekable a, Pokable a, Storable a) => Storable' a
instance (Peekable a, Pokable a, Storable a) => Storable' a

instance {-# OVERLAPPABLE #-} Storable a => Sizable a where
	sizeOf' :: Int
sizeOf' = forall a. Storable a => a -> Int
sizeOf @a a
forall a. HasCallStack => a
undefined
	alignment' :: Int
alignment' = forall a. Storable a => a -> Int
alignment @a a
forall a. HasCallStack => a
undefined

instance {-# OVERLAPPABLE #-} Storable a => Peek a where peek' :: Ptr a -> IO a
peek' = Ptr a -> IO a
forall a. Storable a => Ptr a -> IO a
peek
instance {-# OVERLAPPABLE #-} Storable a => Poke a where poke' :: Ptr a -> a -> IO ()
poke' = Ptr a -> a -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke

withPoked :: Pokable a => a -> (Ptr a -> IO b) -> IO b
withPoked :: forall a b. Pokable a => a -> (Ptr a -> IO b) -> IO b
withPoked a
x Ptr a -> IO b
f = (Ptr a -> IO b) -> IO b
forall a b. Sizable a => (Ptr a -> IO b) -> IO b
alloca' \Ptr a
p -> Ptr a -> a -> IO ()
forall a. Poke a => Ptr a -> a -> IO ()
poke' Ptr a
p a
x IO () -> IO b -> IO b
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Ptr a -> IO b
f Ptr a
p

withPokedMaybe :: Pokable a => Maybe a -> (Ptr a -> IO b) -> IO b
withPokedMaybe :: forall a b. Pokable a => Maybe a -> (Ptr a -> IO b) -> IO b
withPokedMaybe = \case Maybe a
Nothing -> ((Ptr a -> IO b) -> Ptr a -> IO b
forall a b. (a -> b) -> a -> b
$ Ptr a
forall a. Ptr a
NullPtr); Just a
x -> a -> (Ptr a -> IO b) -> IO b
forall a b. Pokable a => a -> (Ptr a -> IO b) -> IO b
withPoked a
x

alloca' :: forall a b . Sizable a => (Ptr a -> IO b) -> IO b
alloca' :: forall a b. Sizable a => (Ptr a -> IO b) -> IO b
alloca' = Int -> Int -> (Ptr a -> IO b) -> IO b
forall a b. Int -> Int -> (Ptr a -> IO b) -> IO b
allocaBytesAligned (forall a. Sizable a => Int
sizeOf' @a) (forall a. Sizable a => Int
alignment' @a)

pattern NullPtr :: Ptr a
pattern $mNullPtr :: forall {r} {a}. Ptr a -> ((# #) -> r) -> ((# #) -> r) -> r
$bNullPtr :: forall a. Ptr a
NullPtr <- ((== nullPtr) -> True) where NullPtr = Ptr a
forall a. Ptr a
nullPtr

peekMaybe :: Peek a => Ptr a -> IO (Maybe a)
peekMaybe :: forall a. Peek a => Ptr a -> IO (Maybe a)
peekMaybe = \case Ptr a
NullPtr -> Maybe a -> IO (Maybe a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing; Ptr a
p -> a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> IO a -> IO (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr a -> IO a
forall a. Peek a => Ptr a -> IO a
peek' Ptr a
p

peekArray' :: forall a . Peekable a => Int -> Ptr a -> IO [a]
peekArray' :: forall a. Peekable a => Int -> Ptr a -> IO [a]
peekArray' Int
n ((Ptr a -> Int -> Ptr a
forall a. Ptr a -> Int -> Ptr a
`alignPtr` (forall a. Sizable a => Int
alignment' @a)) -> Ptr a
p)
	| Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = [a] -> IO [a]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
	| Bool
True = (:) (a -> [a] -> [a]) -> IO a -> IO ([a] -> [a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr a -> IO a
forall a. Peek a => Ptr a -> IO a
peek' Ptr a
p IO ([a] -> [a]) -> IO [a] -> IO [a]
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> Ptr a -> IO [a]
forall a. Peekable a => Int -> Ptr a -> IO [a]
peekArray' (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Ptr a
p Ptr a -> Int -> Ptr a
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` forall a. Sizable a => Int
sizeOf' @a)

newtype PtrS s a = PtrS_ (Ptr a) deriving Int -> PtrS s a -> ShowS
[PtrS s a] -> ShowS
PtrS s a -> String
(Int -> PtrS s a -> ShowS)
-> (PtrS s a -> String) -> ([PtrS s a] -> ShowS) -> Show (PtrS s a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall s a. Int -> PtrS s a -> ShowS
forall s a. [PtrS s a] -> ShowS
forall s a. PtrS s a -> String
$cshowsPrec :: forall s a. Int -> PtrS s a -> ShowS
showsPrec :: Int -> PtrS s a -> ShowS
$cshow :: forall s a. PtrS s a -> String
show :: PtrS s a -> String
$cshowList :: forall s a. [PtrS s a] -> ShowS
showList :: [PtrS s a] -> ShowS
Show

ptrS :: Ptr a -> PtrS s a
ptrS :: forall a s. Ptr a -> PtrS s a
ptrS = Ptr a -> PtrS s a
forall s a. Ptr a -> PtrS s a
PtrS_

castPtrS :: PtrS s a -> PtrS s b
castPtrS :: forall s a b. PtrS s a -> PtrS s b
castPtrS (PtrS_ Ptr a
p) = Ptr b -> PtrS s b
forall s a. Ptr a -> PtrS s a
PtrS_ (Ptr b -> PtrS s b) -> Ptr b -> PtrS s b
forall a b. (a -> b) -> a -> b
$ Ptr a -> Ptr b
forall a b. Ptr a -> Ptr b
castPtr Ptr a
p

pattern NullPtrS :: PtrS s a
pattern $mNullPtrS :: forall {r} {s} {a}. PtrS s a -> ((# #) -> r) -> ((# #) -> r) -> r
$bNullPtrS :: forall s a. PtrS s a
NullPtrS <- PtrS_ NullPtr where NullPtrS = Ptr a -> PtrS s a
forall s a. Ptr a -> PtrS s a
PtrS_ Ptr a
forall a. Ptr a
NullPtr

withPtrS :: PtrS s a -> (Ptr a -> IO b) -> IO ()
withPtrS :: forall s a b. PtrS s a -> (Ptr a -> IO b) -> IO ()
withPtrS (PtrS_ Ptr a
p) = (() () -> IO b -> IO ()
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$) (IO b -> IO ())
-> ((Ptr a -> IO b) -> IO b) -> (Ptr a -> IO b) -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Ptr a -> IO b) -> Ptr a -> IO b
forall a b. (a -> b) -> a -> b
$ Ptr a
p)

class WithPoked a where
	withPoked' :: a -> (forall s . PtrS s a -> IO b) -> IO b

instance {-# OVERLAPPABLE #-} Pokable a => WithPoked a where
	withPoked' :: forall b. a -> (forall s. PtrS s a -> IO b) -> IO b
withPoked' a
x forall s. PtrS s a -> IO b
f = a -> (Ptr a -> IO b) -> IO b
forall a b. Pokable a => a -> (Ptr a -> IO b) -> IO b
withPoked a
x ((Ptr a -> IO b) -> IO b) -> (Ptr a -> IO b) -> IO b
forall a b. (a -> b) -> a -> b
$ PtrS Any a -> IO b
forall s. PtrS s a -> IO b
f (PtrS Any a -> IO b) -> (Ptr a -> PtrS Any a) -> Ptr a -> IO b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr a -> PtrS Any a
forall a s. Ptr a -> PtrS s a
ptrS

withPokedMaybe' :: WithPoked a =>
	Maybe a -> (forall s . PtrS s a -> IO b) -> IO b
withPokedMaybe' :: forall a b.
WithPoked a =>
Maybe a -> (forall s. PtrS s a -> IO b) -> IO b
withPokedMaybe' = \case Maybe a
Nothing -> ((PtrS Any a -> IO b) -> PtrS Any a -> IO b
forall a b. (a -> b) -> a -> b
$ PtrS Any a
forall s a. PtrS s a
NullPtrS); Just a
x -> a -> (forall s. PtrS s a -> IO b) -> IO b
forall b. a -> (forall s. PtrS s a -> IO b) -> IO b
forall a b.
WithPoked a =>
a -> (forall s. PtrS s a -> IO b) -> IO b
withPoked' a
x

instance WithPoked (TPMaybe.M t 'Nothing) where
	withPoked' :: forall b.
M t 'Nothing -> (forall s. PtrS s (M t 'Nothing) -> IO b) -> IO b
withPoked' M t 'Nothing
TPMaybe.N forall s. PtrS s (M t 'Nothing) -> IO b
f = PtrS Any (M t 'Nothing) -> IO b
forall s. PtrS s (M t 'Nothing) -> IO b
f (PtrS Any (M t 'Nothing) -> IO b)
-> PtrS Any (M t 'Nothing) -> IO b
forall a b. (a -> b) -> a -> b
$ Ptr (M t 'Nothing) -> PtrS Any (M t 'Nothing)
forall a s. Ptr a -> PtrS s a
ptrS Ptr (M t 'Nothing)
forall a. Ptr a
nullPtr

instance WithPoked (t a) => WithPoked (TPMaybe.M t ('Just a)) where
	withPoked' :: forall b.
M t ('Just a) -> (forall s. PtrS s (M t ('Just a)) -> IO b) -> IO b
withPoked' (TPMaybe.J t a
x) forall s. PtrS s (M t ('Just a)) -> IO b
f = t a -> (forall s. PtrS s (t a) -> IO b) -> IO b
forall b. t a -> (forall s. PtrS s (t a) -> IO b) -> IO b
forall a b.
WithPoked a =>
a -> (forall s. PtrS s a -> IO b) -> IO b
withPoked' t a
x (PtrS s (M t ('Just a)) -> IO b
forall s. PtrS s (M t ('Just a)) -> IO b
f (PtrS s (M t ('Just a)) -> IO b)
-> (PtrS s (t a) -> PtrS s (M t ('Just a))) -> PtrS s (t a) -> IO b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PtrS s (t a) -> PtrS s (M t ('Just a))
forall s a b. PtrS s a -> PtrS s b
castPtrS)

instance {-# OVERLAPPABLE #-} WithPoked a => WithPoked (TMaybe.Id a) where
	withPoked' :: forall b. Id a -> (forall s. PtrS s (Id a) -> IO b) -> IO b
withPoked' (TMaybe.Id a
x) forall s. PtrS s (Id a) -> IO b
f = a -> (forall s. PtrS s a -> IO b) -> IO b
forall b. a -> (forall s. PtrS s a -> IO b) -> IO b
forall a b.
WithPoked a =>
a -> (forall s. PtrS s a -> IO b) -> IO b
withPoked' a
x (PtrS s (Id a) -> IO b
forall s. PtrS s (Id a) -> IO b
f (PtrS s (Id a) -> IO b)
-> (PtrS s a -> PtrS s (Id a)) -> PtrS s a -> IO b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PtrS s a -> PtrS s (Id a)
forall s a b. PtrS s a -> PtrS s b
castPtrS)