{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE ScopedTypeVariables, TypeApplications, RankNTypes #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE DataKinds, PolyKinds, ConstraintKinds #-}
{-# LANGUAGE KindSignatures, TypeOperators #-}
{-# LANGUAGE MultiParamTypeClasses, AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE PatternSynonyms, ViewPatterns #-}
{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}

module Foreign.Storable.HeteroList (

	-- * SIZE AND ALIGNMENT

	wholeSize, sizeAlignments, infixOffsetSize,
	SizeAlignmentList, InfixOffsetSize, PrefixSize,

	-- * POKABLE

	PokableList(..),

{-
	-- * WITHPOKED

	-- ** Plain

	WithPokedHeteroToListM, withPokedHeteroToListM, withPokedWithHeteroListM,
	WithPokedHeteroToListM', withPokedHeteroToListM',

	-- ** CPS

	WithPokedHeteroToListCpsM,
	withPokedHeteroToListCpsM, withPokedWithHeteroListCpsM,
	WithPokedHeteroToListCpsM',
	withPokedHeteroToListCpsM', withPokedWithHeteroListCpsM'
	-}

	) where

import Foreign.Ptr
import Foreign.Storable.PeekPoke
import Data.Kind
import qualified Data.HeteroParList as HeteroParList
import Data.HeteroParList (pattern (:**))

-- Size and Alignment

{-
class SizableList (as :: [Type]) where sizes :: [Int]; alignments :: [Int]

instance SizableList '[] where sizes = []; alignments = []

instance (Sizable a, SizableList as) => SizableList (a ': as) where
	sizes = sizeOf' @a: sizes @as
	alignments = alignment' @a : alignments @as
	-}

sizeAlignments :: forall as . SizeAlignmentList as => [(Int, Int)]
sizeAlignments :: forall (as :: [*]). SizeAlignmentList as => [(Offset, Offset)]
sizeAlignments = PL SizeAlignmentOfType as -> [(Offset, Offset)]
forall (as :: [*]). PL SizeAlignmentOfType as -> [(Offset, Offset)]
sizeAlignmentsFromSizeAlignmentList (forall (ts :: [*]).
SizeAlignmentList ts =>
PL SizeAlignmentOfType ts
sizeAlignmentList @as)
	-- zip (sizes @as) (alignments @as)

sizeAlignmentsFromSizeAlignmentList ::
	HeteroParList.PL SizeAlignmentOfType as -> [(Int, Int)]
sizeAlignmentsFromSizeAlignmentList :: forall (as :: [*]). PL SizeAlignmentOfType as -> [(Offset, Offset)]
sizeAlignmentsFromSizeAlignmentList PL SizeAlignmentOfType as
HeteroParList.Nil = []
sizeAlignmentsFromSizeAlignmentList
	(SizeAlignmentOfType Offset
sz Offset
algn :** PL SizeAlignmentOfType ss1
sas) =
	(Offset
sz, Offset
algn) (Offset, Offset) -> [(Offset, Offset)] -> [(Offset, Offset)]
forall a. a -> [a] -> [a]
: PL SizeAlignmentOfType ss1 -> [(Offset, Offset)]
forall (as :: [*]). PL SizeAlignmentOfType as -> [(Offset, Offset)]
sizeAlignmentsFromSizeAlignmentList PL SizeAlignmentOfType ss1
sas

wholeSize :: forall as . SizeAlignmentList as => Int
wholeSize :: forall (as :: [*]). SizeAlignmentList as => Offset
wholeSize = Offset -> [(Offset, Offset)] -> Offset
calcSize Offset
0 ([(Offset, Offset)] -> Offset) -> [(Offset, Offset)] -> Offset
forall a b. (a -> b) -> a -> b
$ forall (as :: [*]). SizeAlignmentList as => [(Offset, Offset)]
sizeAlignments @as

calcSize :: Int -> [(Int, Int)] -> Int
calcSize :: Offset -> [(Offset, Offset)] -> Offset
calcSize Offset
n [] = Offset
n
calcSize Offset
n ((Offset
sz, Offset
al) : [(Offset, Offset)]
szals) = Offset -> [(Offset, Offset)] -> Offset
calcSize (((Offset
n Offset -> Offset -> Offset
forall a. Num a => a -> a -> a
- Offset
1) Offset -> Offset -> Offset
forall a. Integral a => a -> a -> a
`div` Offset
al Offset -> Offset -> Offset
forall a. Num a => a -> a -> a
+ Offset
1) Offset -> Offset -> Offset
forall a. Num a => a -> a -> a
* Offset
al Offset -> Offset -> Offset
forall a. Num a => a -> a -> a
+ Offset
sz) [(Offset, Offset)]
szals

infixOffsetSize :: forall (part :: [Type]) (whole :: [Type]) .
	InfixOffsetSize part whole => (Offset, Size)
infixOffsetSize :: forall (part :: [*]) (whole :: [*]).
InfixOffsetSize part whole =>
(Offset, Offset)
infixOffsetSize = forall (part :: [*]) (whole :: [*]).
InfixOffsetSize part whole =>
Offset -> PL SizeAlignmentOfType whole -> (Offset, Offset)
infixOffsetSizeFromSizeAlignmentList @part @whole
	Offset
0 (forall (ts :: [*]).
SizeAlignmentList ts =>
PL SizeAlignmentOfType ts
sizeAlignmentList @whole)

data SizeAlignmentOfType (tp :: Type) = SizeAlignmentOfType Size Alignment
	deriving Offset -> SizeAlignmentOfType tp -> ShowS
[SizeAlignmentOfType tp] -> ShowS
SizeAlignmentOfType tp -> String
(Offset -> SizeAlignmentOfType tp -> ShowS)
-> (SizeAlignmentOfType tp -> String)
-> ([SizeAlignmentOfType tp] -> ShowS)
-> Show (SizeAlignmentOfType tp)
forall tp. Offset -> SizeAlignmentOfType tp -> ShowS
forall tp. [SizeAlignmentOfType tp] -> ShowS
forall tp. SizeAlignmentOfType tp -> String
forall a.
(Offset -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall tp. Offset -> SizeAlignmentOfType tp -> ShowS
showsPrec :: Offset -> SizeAlignmentOfType tp -> ShowS
$cshow :: forall tp. SizeAlignmentOfType tp -> String
show :: SizeAlignmentOfType tp -> String
$cshowList :: forall tp. [SizeAlignmentOfType tp] -> ShowS
showList :: [SizeAlignmentOfType tp] -> ShowS
Show

type Size = Int; type Alignment = Int; type Offset = Int

class SizeAlignmentList ts where
	sizeAlignmentList :: HeteroParList.PL SizeAlignmentOfType ts

instance SizeAlignmentList '[] where sizeAlignmentList :: PL SizeAlignmentOfType '[]
sizeAlignmentList = PL SizeAlignmentOfType '[]
forall {k} (t :: k -> *). PL t '[]
HeteroParList.Nil

instance (Sizable t, SizeAlignmentList ts) => SizeAlignmentList (t ': ts) where
	sizeAlignmentList :: PL SizeAlignmentOfType (t : ts)
sizeAlignmentList = Offset -> Offset -> SizeAlignmentOfType t
forall tp. Offset -> Offset -> SizeAlignmentOfType tp
SizeAlignmentOfType (forall a. Sizable a => Offset
sizeOf' @t) (forall a. Sizable a => Offset
alignment' @t) SizeAlignmentOfType t
-> PL SizeAlignmentOfType ts -> PL SizeAlignmentOfType (t : ts)
forall {k} (t :: k -> *) (s :: k) (ss1 :: [k]).
t s -> PL t ss1 -> PL t (s : ss1)
:**
		forall (ts :: [*]).
SizeAlignmentList ts =>
PL SizeAlignmentOfType ts
sizeAlignmentList @ts

class SizeAlignmentList whole => InfixOffsetSize (part :: [Type]) whole where
	infixOffsetSizeFromSizeAlignmentList :: Size ->
		HeteroParList.PL SizeAlignmentOfType whole -> (Offset, Size)

instance (
	Sizable t, SizeAlignmentList whole,
	(t ': ts) `PrefixSize` (t ': whole) ) =>
	InfixOffsetSize (t ': ts) (t ': whole) where
	infixOffsetSizeFromSizeAlignmentList :: Offset -> PL SizeAlignmentOfType (t : whole) -> (Offset, Offset)
infixOffsetSizeFromSizeAlignmentList Offset
sz0
		saa :: PL SizeAlignmentOfType (t : whole)
saa@(SizeAlignmentOfType Offset
_ Offset
algn :** PL SizeAlignmentOfType ss1
_) = (
			Offset -> Offset -> Offset
align Offset
algn Offset
sz0,
			forall (part :: [*]) (whole :: [*]).
PrefixSize part whole =>
Offset -> PL SizeAlignmentOfType whole -> Offset
prefixSizeFromSizeAlignmentList @(t ': ts) Offset
0 PL SizeAlignmentOfType (t : whole)
saa )

instance {-# OVERLAPPABLE #-} (Sizable t, InfixOffsetSize ts whole) =>
	InfixOffsetSize ts (t ': whole) where
	infixOffsetSizeFromSizeAlignmentList :: Offset -> PL SizeAlignmentOfType (t : whole) -> (Offset, Offset)
infixOffsetSizeFromSizeAlignmentList Offset
sz0
		(SizeAlignmentOfType Offset
sz Offset
algn :** PL SizeAlignmentOfType ss1
sas) =
		forall (part :: [*]) (whole :: [*]).
InfixOffsetSize part whole =>
Offset -> PL SizeAlignmentOfType whole -> (Offset, Offset)
infixOffsetSizeFromSizeAlignmentList @ts
			(Offset -> Offset -> Offset
align Offset
algn Offset
sz0 Offset -> Offset -> Offset
forall a. Num a => a -> a -> a
+ Offset
sz) PL SizeAlignmentOfType ss1
sas

class PrefixSize (part :: [Type]) whole where
	prefixSizeFromSizeAlignmentList :: Size ->
		HeteroParList.PL SizeAlignmentOfType whole -> Size

instance PrefixSize '[] whole where prefixSizeFromSizeAlignmentList :: Offset -> PL SizeAlignmentOfType whole -> Offset
prefixSizeFromSizeAlignmentList Offset
sz PL SizeAlignmentOfType whole
_ = Offset
sz

instance PrefixSize ts whole => PrefixSize (t ': ts) (t ': whole) where
	prefixSizeFromSizeAlignmentList :: Offset -> PL SizeAlignmentOfType (t : whole) -> Offset
prefixSizeFromSizeAlignmentList Offset
sz0
		(SizeAlignmentOfType Offset
sz Offset
algn :** PL SizeAlignmentOfType ss1
sas) =
		forall (part :: [*]) (whole :: [*]).
PrefixSize part whole =>
Offset -> PL SizeAlignmentOfType whole -> Offset
prefixSizeFromSizeAlignmentList @ts (Offset -> Offset -> Offset
align Offset
algn Offset
sz0 Offset -> Offset -> Offset
forall a. Num a => a -> a -> a
+ Offset
sz) PL SizeAlignmentOfType ss1
sas

align :: Alignment -> Size -> Offset
align :: Offset -> Offset -> Offset
align Offset
algn Offset
sz = ((Offset
sz Offset -> Offset -> Offset
forall a. Num a => a -> a -> a
- Offset
1) Offset -> Offset -> Offset
forall a. Integral a => a -> a -> a
`div` Offset
algn Offset -> Offset -> Offset
forall a. Num a => a -> a -> a
+ Offset
1) Offset -> Offset -> Offset
forall a. Num a => a -> a -> a
* Offset
algn

-- Pokable

class SizeAlignmentList as => PokableList (as :: [Type]) where
	pokeList :: Ptr x -> HeteroParList.L as -> IO ()

instance PokableList '[] where
	pokeList :: forall x. Ptr x -> L '[] -> IO ()
pokeList Ptr x
_ L '[]
HeteroParList.Nil = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

instance (Pokable a, PokableList as) => PokableList (a ': as) where
	pokeList :: forall x. Ptr x -> L (a : as) -> IO ()
pokeList ((Ptr x -> Offset -> Ptr x
forall a. Ptr a -> Offset -> Ptr a
`alignPtr` forall a. Sizable a => Offset
alignment' @a) -> Ptr x
p) (HeteroParList.Id s
x :** PL Id ss1
xs) = do
		Ptr s -> s -> IO ()
forall a. Poke a => Ptr a -> a -> IO ()
poke' (Ptr x -> Ptr s
forall a b. Ptr a -> Ptr b
castPtr Ptr x
p) s
x
		Ptr Any -> PL Id ss1 -> IO ()
forall (as :: [*]) x. PokableList as => Ptr x -> L as -> IO ()
forall x. Ptr x -> PL Id ss1 -> IO ()
pokeList (Ptr x
p Ptr x -> Offset -> Ptr Any
forall a b. Ptr a -> Offset -> Ptr b
`plusPtr` forall a. Sizable a => Offset
sizeOf' @a) PL Id ss1
xs

{-
-- WithPoked

type WithPokedHeteroToListM = HeteroParList.ToListWithCM WithPoked

withPokedHeteroToListM :: (
	WithPokedHeteroToListM ss, Applicative m ) =>
	(forall s . WithPoked s => t s -> m a) -> HeteroParList.PL t ss -> m [a]
withPokedHeteroToListM = HeteroParList.toListWithCM @WithPoked

type WithPokedHeteroToListM' = HeteroParList.ToListWithCM' WithPoked

withPokedHeteroToListM' :: forall k t' t ss m a .
	(WithPokedHeteroToListM' t' ss, Applicative m) =>
	(forall (s :: k) . WithPoked (t' s) => t s -> m a) ->
	HeteroParList.PL t ss -> m [a]
withPokedHeteroToListM' = HeteroParList.toListWithCM' @_ @_ @WithPoked @t'

withPokedWithHeteroListM :: (WithPokedHeteroToListM ss, Applicative m) =>
		HeteroParList.PL t ss ->
		(forall s . WithPoked s => t s -> m a) -> m [a]
withPokedWithHeteroListM xs f = withPokedHeteroToListM f xs

type WithPokedHeteroToListCpsM = HeteroParList.ToListWithCCpsM WithPoked

withPokedHeteroToListCpsM :: WithPokedHeteroToListCpsM ns =>
	(forall s . WithPoked s => t s -> (a -> m b) -> m b) ->
	HeteroParList.PL t ns ->
	([a] -> m b) -> m b
withPokedHeteroToListCpsM = HeteroParList.toListWithCCpsM @WithPoked

withPokedWithHeteroListCpsM :: WithPokedHeteroToListCpsM ss =>
	HeteroParList.PL t ss ->
	(forall s . WithPoked s => t s -> (a -> m b) -> m b) ->
	([a] -> m b) -> m b
withPokedWithHeteroListCpsM f xs = withPokedHeteroToListCpsM xs f

type WithPokedHeteroToListCpsM' =
	HeteroParList.ToListWithCCpsM' WithPoked

withPokedHeteroToListCpsM' :: forall k t' t ns a m b .
	WithPokedHeteroToListCpsM' t' ns =>
	(forall (s :: k) . WithPoked (t' s) => t s -> (a -> m b) -> m b) ->
	HeteroParList.PL t ns -> ([a] -> m b) -> m b
withPokedHeteroToListCpsM' =
	HeteroParList.toListWithCCpsM' @_ @WithPoked @t'

withPokedWithHeteroListCpsM' :: forall t' t ss a m b .
	WithPokedHeteroToListCpsM' t' ss =>
	HeteroParList.PL t ss ->
	(forall s . WithPoked (t' s) => t s -> (a -> m b) -> m b) ->
	([a] -> m b) -> m b
withPokedWithHeteroListCpsM' f xs = withPokedHeteroToListCpsM' @_ @t' xs f
-}