gl-block-1.1: src/Graphics/Gl/Block.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

{-|
Copyright:  (c) 2023-206 IC Rainbow
            (c) 2014-2019 Edward Kmett
License : BSD-2-Clause OR Apache-2.0
Maintainer: IC Rainbow <aenor.realm@gmail.com>
Stability: experimental
Portability: non-portable

OpenGL std140 and std430 support
-}
module Graphics.Gl.Block
  ( Block (..)
  , GBlock (..)
  , Packed (..)
  , Std140 (..)
  , Std430 (..)
  , roundUp
  ) where

import Control.Monad.IO.Class (MonadIO (..))
import Data.Data (Data, Typeable)
import Data.Int (Int16, Int32, Int64)
import Data.Proxy (Proxy (..))
import Data.Word (Word16, Word32, Word64)
import Foreign.C.Types
import Foreign.Ptr (Ptr)
import Foreign.Ptr.Diff (Diff (..), peekDiffOff, pokeDiffOff)
import Foreign.Storable (Storable (..))
import GHC.Generics (C, D, Generic, K1 (..), M1 (..), Rep, S, U1 (..), from, to, (:*:) (..))
import GHC.TypeLits (KnownNat, Nat, natVal, type (+))
import Numeric.Half (Half)

newtype Packed a = Packed {getPacked :: a}
  deriving (Data, Typeable, Generic, Functor, Foldable, Traversable, Eq, Ord, Show, Read)

instance (Block a) => Storable (Packed a) where
  alignment _ = 1
  sizeOf _ = sizeOfPacked (Proxy :: Proxy a)
  peekByteOff p o = Packed <$> readPacked p (Diff o)
  pokeByteOff p o = writePacked p (Diff o) . getPacked

newtype Std140 a = Std140 {getStd140 :: a}
  deriving (Data, Typeable, Generic, Functor, Foldable, Traversable, Eq, Ord, Show, Read)

instance (Block a) => Storable (Std140 a) where
  alignment _ = alignment140 (Proxy :: Proxy a)
  sizeOf _ = sizeOf140 (Proxy :: Proxy a)
  peekByteOff p o = Std140 <$> read140 p (Diff o)
  pokeByteOff p o = write140 p (Diff o) . getStd140

newtype Std430 a = Std430 {getStd430 :: a}
  deriving (Data, Typeable, Generic, Functor, Foldable, Traversable, Eq, Ord, Show, Read)

instance (Block a) => Storable (Std430 a) where
  alignment _ = alignment430 (Proxy :: Proxy a)
  sizeOf _ = sizeOf430 (Proxy :: Proxy a)
  peekByteOff p o = Std430 <$> read430 p (Diff o)
  pokeByteOff p o = write430 p (Diff o) . getStd430

{- | This describes how to load and store primitives
through a uniform/shader storage blocks according to
OpenGL Std140 and Std430.

There are lots of fiddly little constants around, beware.
-}
class Block b where
  -- | As per 'Storable' 'alignment', but matching OpenGL Std140.
  alignment140 :: proxy b -> Int
  default alignment140 :: (GBlock (Rep b)) => proxy b -> Int
  alignment140 _ = galignment140 (Proxy :: Proxy (Rep b))

  -- | As per 'Storable' 'sizeOf', but matching OpenGL Std140.
  sizeOf140 :: proxy b -> Int
  default sizeOf140 :: (GBlock (Rep b)) => proxy b -> Int
  sizeOf140 _ = gsizeOf140 (Proxy :: Proxy (Rep b))

  -- | Structures get smashed up to a minimum of a vec4 alignment in 140 mode
  isStruct :: proxy b -> Bool
  isStruct _ = True

  read140 :: (MonadIO m) => Ptr a -> Diff a b -> m b
  default read140 :: (MonadIO m, Generic b, GBlock (Rep b)) => Ptr a -> Diff a b -> m b
  read140 p (Diff o) = liftIO $ to <$> gread140 p o

  write140 :: (MonadIO m) => Ptr a -> Diff a b -> b -> m ()
  default write140 :: (MonadIO m, Generic b, GBlock (Rep b)) => Ptr a -> Diff a b -> b -> m ()
  write140 p (Diff o) b = liftIO $ gwrite140 p o (from b)

  -- | As per 'Storable' 'alignment', but matching OpenGL Std430.
  alignment430 :: proxy b -> Int
  default alignment430 :: (GBlock (Rep b)) => proxy b -> Int
  alignment430 _ = galignment430 (Proxy :: Proxy (Rep b))

  -- | As per 'Storable' 'sizeOf', but matching OpenGL Std430.
  sizeOf430 :: proxy b -> Int
  default sizeOf430 :: (GBlock (Rep b)) => proxy b -> Int
  sizeOf430 _ = gsizeOf430 (Proxy :: Proxy (Rep b))

  read430 :: (MonadIO m) => Ptr a -> Diff a b -> m b
  default read430 :: (MonadIO m, Generic b, GBlock (Rep b)) => Ptr a -> Diff a b -> m b
  read430 p (Diff o) = liftIO $ to <$> gread430 p o

  write430 :: (MonadIO m) => Ptr a -> Diff a b -> b -> m ()
  default write430 :: (MonadIO m, Generic b, GBlock (Rep b)) => Ptr a -> Diff a b -> b -> m ()
  write430 p (Diff o) b = liftIO $ gwrite430 p o (from b)

  type PackedSize b :: Nat
  type PackedSize b = GPackedSize (Rep b)

  -- | As per 'Storable' 'sizeOf', but without padding and no alignment
  sizeOfPacked :: proxy b -> Int
  default sizeOfPacked :: (KnownNat (PackedSize b)) => proxy b -> Int
  sizeOfPacked _ = fromInteger $! natVal (Proxy :: Proxy (PackedSize b))

  readPacked :: (MonadIO m) => Ptr a -> Diff a b -> m b
  default readPacked :: (MonadIO m, Generic b, GBlock (Rep b)) => Ptr a -> Diff a b -> m b
  readPacked p (Diff o) = liftIO $ to <$> greadPacked p o

  writePacked :: (MonadIO m) => Ptr a -> Diff a b -> b -> m ()
  default writePacked :: (MonadIO m, Generic b, GBlock (Rep b)) => Ptr a -> Diff a b -> b -> m ()
  writePacked p (Diff o) b = liftIO $ gwritePacked p o (from b)

-- | Automatically derive Std140 and Std430 alignment using GHC Generics
class GBlock f where
  type GPackedSize f :: Nat
  galignment140 :: p f -> Int
  galignment430 :: p f -> Int
  gsizeOf140 :: p f -> Int
  gsizeOf430 :: p f -> Int
  gsizeOfPacked :: p f -> Int

  {- | The base offset of the member that would follow this subtree, given the
  subtree itself begins at base offset @o@. Threads the offset through the
  product left-to-right: each scalar leaf rounds @o@ up to its /own/ base
  alignment and adds its size.

  This is the member-offset rule from the OpenGL spec, §7.6.2.2 (Standard
  Uniform Block Layout, std140; std430 relaxes the same rule):

  > A structure and each structure member have a base offset and a base
  > alignment [...]. The base offset of the first member of a structure is
  > taken from the aligned offset of the structure itself. The base offset of
  > all other structure members is derived by taking the offset of the last
  > basic machine unit consumed by the previous member and adding one. Each
  > structure member is stored in memory at its aligned offset [the base
  > offset rounded up to a multiple of its base alignment].

  Rounding to each member's /own/ alignment -- rather than to a whole
  subtree's maximum alignment -- is what stops a low-alignment field from
  being over-padded when a later sibling in the same product has a higher
  alignment.
  -}
  gnextOffset140 :: p f -> Int -> Int

  gnextOffset430 :: p f -> Int -> Int

  gread140 :: Ptr a -> Int -> IO (f b)
  gread430 :: Ptr a -> Int -> IO (f b)
  greadPacked :: Ptr a -> Int -> IO (f b)
  gwrite140 :: Ptr a -> Int -> f b -> IO ()
  gwrite430 :: Ptr a -> Int -> f b -> IO ()
  gwritePacked :: Ptr a -> Int -> f b -> IO ()

instance GBlock U1 where
  type GPackedSize U1 = 0
  galignment140 _ = 1
  gsizeOf140 _ = 0
  galignment430 _ = 1
  gsizeOf430 _ = 0
  gsizeOfPacked _ = 0
  gnextOffset140 _ o = o
  gnextOffset430 _ o = o
  gread140 _ _ = return U1
  gread430 _ _ = return U1
  greadPacked _ _ = return U1
  gwrite140 _ _ U1 = return ()
  gwrite430 _ _ U1 = return ()
  gwritePacked _ _ U1 = return ()

instance (GBlock f, GBlock g) => GBlock (f :*: g) where
  type GPackedSize (f :*: g) = GPackedSize f + GPackedSize g

  gsizeOfPacked _ =
    gsizeOfPacked (Proxy :: Proxy f) + gsizeOfPacked (Proxy :: Proxy g)

  galignment140 _ =
    max
      (galignment140 (Proxy :: Proxy f))
      (galignment140 (Proxy :: Proxy g))

  galignment430 _ =
    max
      (galignment430 (Proxy :: Proxy f))
      (galignment430 (Proxy :: Proxy g))

  -- The content extent is the offset reached after laying out both halves from
  -- offset 0 (each leaf rounds itself to its own alignment along the way).
  gsizeOf140 _ = gnextOffset140 (Proxy :: Proxy (f :*: g)) 0
  gsizeOf430 _ = gnextOffset430 (Proxy :: Proxy (f :*: g)) 0

  gnextOffset140 _ o = gnextOffset140 (Proxy :: Proxy g) (gnextOffset140 (Proxy :: Proxy f) o)
  gnextOffset430 _ o = gnextOffset430 (Proxy :: Proxy g) (gnextOffset430 (Proxy :: Proxy f) o)

  gread140 p o =
    (:*:)
      <$> gread140 p o
      <*> gread140 p (gnextOffset140 (Proxy :: Proxy f) o)

  gread430 p o =
    (:*:)
      <$> gread430 p o
      <*> gread430 p (gnextOffset430 (Proxy :: Proxy f) o)

  greadPacked p o =
    (:*:)
      <$> greadPacked p o
      <*> greadPacked p (o + gsizeOfPacked (Proxy :: Proxy f))

  gwrite140 p o (a :*: b) = do
    gwrite140 p o a
    gwrite140 p (gnextOffset140 (Proxy :: Proxy f) o) b

  gwrite430 p o (a :*: b) = do
    gwrite430 p o a
    gwrite430 p (gnextOffset430 (Proxy :: Proxy f) o) b

  gwritePacked p o (a :*: b) = do
    gwritePacked p o a
    gwritePacked p (o + gsizeOfPacked (Proxy :: Proxy f)) b

instance (GBlock f) => GBlock (M1 S c f) where
  type GPackedSize (M1 S c f) = GPackedSize f
  galignment140 _ = galignment140 (Proxy :: Proxy f)
  galignment430 _ = galignment430 (Proxy :: Proxy f)
  gsizeOf140 _ = gsizeOf140 (Proxy :: Proxy f)
  gsizeOf430 _ = gsizeOf430 (Proxy :: Proxy f)
  gsizeOfPacked _ = gsizeOfPacked (Proxy :: Proxy f)
  gnextOffset140 _ = gnextOffset140 (Proxy :: Proxy f)
  gnextOffset430 _ = gnextOffset430 (Proxy :: Proxy f)
  gread140 p o = M1 <$> gread140 p o
  gread430 p o = M1 <$> gread430 p o
  greadPacked p o = M1 <$> greadPacked p o
  gwrite140 p o (M1 a) = gwrite140 p o a
  gwrite430 p o (M1 a) = gwrite430 p o a
  gwritePacked p o (M1 a) = gwritePacked p o a

instance (GBlock f) => GBlock (M1 C c f) where
  type GPackedSize (M1 C c f) = GPackedSize f
  galignment140 _ = roundUp (galignment140 (Proxy :: Proxy f)) 16 -- std140 rule 9: round the struct's alignment up to a vec4
  galignment430 _ = galignment430 (Proxy :: Proxy f) -- std140 rule 9, relaxed by std430
  gsizeOf140 _ = roundUp (gsizeOf140 (Proxy :: Proxy f)) align -- std140 rule 9: pad to the struct's own (vec4-rounded) alignment
    where
      align = roundUp (galignment140 (Proxy :: Proxy f)) 16
  gsizeOf430 _ = roundUp (gsizeOf430 (Proxy :: Proxy f)) (galignment430 (Proxy :: Proxy f)) -- std140 rule 9, relaxed by std430
  gsizeOfPacked _ = gsizeOfPacked (Proxy :: Proxy f)
  gnextOffset140 _ = gnextOffset140 (Proxy :: Proxy f) -- a constructor is only ever the top of a Rep, never a product child
  gnextOffset430 _ = gnextOffset430 (Proxy :: Proxy f)
  gread140 p o = M1 <$> gread140 p o
  gread430 p o = M1 <$> gread430 p o
  greadPacked p o = M1 <$> greadPacked p o
  gwrite140 p o (M1 a) = gwrite140 p o a
  gwrite430 p o (M1 a) = gwrite430 p o a
  gwritePacked p o (M1 a) = gwritePacked p o a

instance (GBlock f) => GBlock (M1 D c f) where
  type GPackedSize (M1 D c f) = GPackedSize f
  galignment140 _ = galignment140 (Proxy :: Proxy f)
  galignment430 _ = galignment430 (Proxy :: Proxy f)
  gsizeOf140 _ = gsizeOf140 (Proxy :: Proxy f)
  gsizeOf430 _ = gsizeOf430 (Proxy :: Proxy f)
  gsizeOfPacked _ = gsizeOfPacked (Proxy :: Proxy f)
  gnextOffset140 _ = gnextOffset140 (Proxy :: Proxy f)
  gnextOffset430 _ = gnextOffset430 (Proxy :: Proxy f)
  gread140 p o = M1 <$> gread140 p o
  gread430 p o = M1 <$> gread430 p o
  greadPacked p o = M1 <$> greadPacked p o
  gwrite140 p o (M1 a) = gwrite140 p o a
  gwrite430 p o (M1 a) = gwrite430 p o a
  gwritePacked p o (M1 a) = gwritePacked p o a

instance (Block c) => GBlock (K1 i c) where
  type GPackedSize (K1 i c) = PackedSize c
  galignment140 _ = alignment140 (Proxy :: Proxy c)
  galignment430 _ = alignment430 (Proxy :: Proxy c)
  gsizeOf140 _ = sizeOf140 (Proxy :: Proxy c)
  gsizeOf430 _ = sizeOf430 (Proxy :: Proxy c)
  gsizeOfPacked _ = sizeOfPacked (Proxy :: Proxy c)
  gnextOffset140 _ o = roundUp o (alignment140 (Proxy :: Proxy c)) + sizeOf140 (Proxy :: Proxy c)
  gnextOffset430 _ o = roundUp o (alignment430 (Proxy :: Proxy c)) + sizeOf430 (Proxy :: Proxy c)
  gread140 p o = K1 <$> read140 p (Diff (roundUp o (alignment140 (Proxy :: Proxy c))))
  gread430 p o = K1 <$> read430 p (Diff (roundUp o (alignment430 (Proxy :: Proxy c))))
  greadPacked p o = K1 <$> readPacked p (Diff o)
  gwrite140 p o (K1 a) = write140 p (Diff (roundUp o (alignment140 (Proxy :: Proxy c)))) a
  gwrite430 p o (K1 a) = write430 p (Diff (roundUp o (alignment430 (Proxy :: Proxy c)))) a
  gwritePacked p o (K1 a) = writePacked p (Diff o) a

toBool :: Int32 -> Bool
toBool 0 = False
toBool _ = True

fromBool :: Bool -> Int32
fromBool False = 0
fromBool True = 1

instance Block Bool where
  type PackedSize Bool = 4
  alignment140 _ = 4
  sizeOf140 = sizeOfPacked
  alignment430 = alignment140
  sizeOf430 = sizeOf140
  isStruct _ = False
  read140 p (Diff d) = fmap toBool $ peekDiffOff p (Diff d)
  write140 p (Diff d) = pokeDiffOff p (Diff d) . fromBool
  read430 = read140
  write430 = write140
  readPacked = read140
  writePacked = write140
  {-# INLINE alignment140 #-}
  {-# INLINE sizeOf140 #-}
  {-# INLINE alignment430 #-}
  {-# INLINE sizeOf430 #-}
  {-# INLINE isStruct #-}
  {-# INLINE read140 #-}
  {-# INLINE write140 #-}
  {-# INLINE read430 #-}
  {-# INLINE write430 #-}
  {-# INLINE readPacked #-}
  {-# INLINE writePacked #-}

instance Block Int16 where
  type PackedSize Int16 = 2
  alignment140 _ = 2
  sizeOf140 = sizeOfPacked
  alignment430 = alignment140
  sizeOf430 = sizeOf140
  isStruct _ = False
  read140 = peekDiffOff
  write140 = pokeDiffOff
  read430 = read140
  write430 = write140
  readPacked = read140
  writePacked = write140
  {-# INLINE alignment140 #-}
  {-# INLINE sizeOf140 #-}
  {-# INLINE alignment430 #-}
  {-# INLINE sizeOf430 #-}
  {-# INLINE isStruct #-}
  {-# INLINE read140 #-}
  {-# INLINE write140 #-}
  {-# INLINE read430 #-}
  {-# INLINE write430 #-}
  {-# INLINE readPacked #-}
  {-# INLINE writePacked #-}

instance Block CShort where
  type PackedSize CShort = 2
  alignment140 _ = 2
  sizeOf140 = sizeOfPacked
  alignment430 = alignment140
  sizeOf430 = sizeOf140
  isStruct _ = False
  read140 = peekDiffOff
  write140 = pokeDiffOff
  read430 = read140
  write430 = write140
  readPacked = read140
  writePacked = write140
  {-# INLINE alignment140 #-}
  {-# INLINE sizeOf140 #-}
  {-# INLINE alignment430 #-}
  {-# INLINE sizeOf430 #-}
  {-# INLINE isStruct #-}
  {-# INLINE read140 #-}
  {-# INLINE write140 #-}
  {-# INLINE read430 #-}
  {-# INLINE write430 #-}
  {-# INLINE readPacked #-}
  {-# INLINE writePacked #-}

instance Block Word16 where
  type PackedSize Word16 = 2
  alignment140 _ = 2
  sizeOf140 = sizeOfPacked
  alignment430 = alignment140
  sizeOf430 = sizeOf140
  isStruct _ = False
  read140 = peekDiffOff
  write140 = pokeDiffOff
  read430 = read140
  write430 = write140
  readPacked = read140
  writePacked = write140
  {-# INLINE alignment140 #-}
  {-# INLINE sizeOf140 #-}
  {-# INLINE alignment430 #-}
  {-# INLINE sizeOf430 #-}
  {-# INLINE isStruct #-}
  {-# INLINE read140 #-}
  {-# INLINE write140 #-}
  {-# INLINE read430 #-}
  {-# INLINE write430 #-}
  {-# INLINE readPacked #-}
  {-# INLINE writePacked #-}

instance Block CUShort where
  type PackedSize CUShort = 2
  alignment140 _ = 2
  sizeOf140 = sizeOfPacked
  alignment430 = alignment140
  sizeOf430 = sizeOf140
  isStruct _ = False
  read140 = peekDiffOff
  write140 = pokeDiffOff
  read430 = read140
  write430 = write140
  readPacked = read140
  writePacked = write140
  {-# INLINE alignment140 #-}
  {-# INLINE sizeOf140 #-}
  {-# INLINE alignment430 #-}
  {-# INLINE sizeOf430 #-}
  {-# INLINE isStruct #-}
  {-# INLINE read140 #-}
  {-# INLINE write140 #-}
  {-# INLINE read430 #-}
  {-# INLINE write430 #-}
  {-# INLINE readPacked #-}
  {-# INLINE writePacked #-}

instance Block Int32 where
  type PackedSize Int32 = 4
  alignment140 _ = 4
  sizeOf140 = sizeOfPacked
  alignment430 = alignment140
  sizeOf430 = sizeOf140
  isStruct _ = False
  read140 = peekDiffOff
  write140 = pokeDiffOff
  read430 = read140
  write430 = write140
  readPacked = read140
  writePacked = write140
  {-# INLINE alignment140 #-}
  {-# INLINE sizeOf140 #-}
  {-# INLINE alignment430 #-}
  {-# INLINE sizeOf430 #-}
  {-# INLINE isStruct #-}
  {-# INLINE read140 #-}
  {-# INLINE write140 #-}
  {-# INLINE read430 #-}
  {-# INLINE write430 #-}
  {-# INLINE readPacked #-}
  {-# INLINE writePacked #-}

instance Block CInt where
  type PackedSize CInt = 4
  alignment140 _ = 4
  sizeOf140 = sizeOfPacked
  alignment430 = alignment140
  sizeOf430 = sizeOf140
  isStruct _ = False
  read140 = peekDiffOff
  write140 = pokeDiffOff
  read430 = read140
  write430 = write140
  readPacked = read140
  writePacked = write140
  {-# INLINE alignment140 #-}
  {-# INLINE sizeOf140 #-}
  {-# INLINE alignment430 #-}
  {-# INLINE sizeOf430 #-}
  {-# INLINE isStruct #-}
  {-# INLINE read140 #-}
  {-# INLINE write140 #-}
  {-# INLINE read430 #-}
  {-# INLINE write430 #-}
  {-# INLINE readPacked #-}
  {-# INLINE writePacked #-}

instance Block Word32 where
  type PackedSize Word32 = 4
  alignment140 _ = 4
  sizeOf140 = sizeOfPacked
  alignment430 = alignment140
  sizeOf430 = sizeOf140
  isStruct _ = False
  read140 = peekDiffOff
  write140 = pokeDiffOff
  read430 = read140
  write430 = write140
  readPacked = read140
  writePacked = write140
  {-# INLINE alignment140 #-}
  {-# INLINE sizeOf140 #-}
  {-# INLINE alignment430 #-}
  {-# INLINE sizeOf430 #-}
  {-# INLINE isStruct #-}
  {-# INLINE read140 #-}
  {-# INLINE write140 #-}
  {-# INLINE read430 #-}
  {-# INLINE write430 #-}
  {-# INLINE readPacked #-}
  {-# INLINE writePacked #-}

instance Block CUInt where
  type PackedSize CUInt = 4
  alignment140 _ = 4
  sizeOf140 = sizeOfPacked
  alignment430 = alignment140
  sizeOf430 = sizeOf140
  isStruct _ = False
  read140 = peekDiffOff
  write140 = pokeDiffOff
  read430 = read140
  write430 = write140
  readPacked = read140
  writePacked = write140
  {-# INLINE alignment140 #-}
  {-# INLINE sizeOf140 #-}
  {-# INLINE alignment430 #-}
  {-# INLINE sizeOf430 #-}
  {-# INLINE isStruct #-}
  {-# INLINE read140 #-}
  {-# INLINE write140 #-}
  {-# INLINE read430 #-}
  {-# INLINE write430 #-}
  {-# INLINE readPacked #-}
  {-# INLINE writePacked #-}

instance Block Float where
  type PackedSize Float = 4
  alignment140 _ = 4
  sizeOf140 = sizeOfPacked
  alignment430 = alignment140
  sizeOf430 = sizeOf140
  isStruct _ = False
  read140 = peekDiffOff
  write140 = pokeDiffOff
  read430 = read140
  write430 = write140
  readPacked = read140
  writePacked = write140
  {-# INLINE alignment140 #-}
  {-# INLINE sizeOf140 #-}
  {-# INLINE alignment430 #-}
  {-# INLINE sizeOf430 #-}
  {-# INLINE isStruct #-}
  {-# INLINE read140 #-}
  {-# INLINE write140 #-}
  {-# INLINE read430 #-}
  {-# INLINE write430 #-}
  {-# INLINE readPacked #-}
  {-# INLINE writePacked #-}

instance Block CFloat where
  type PackedSize CFloat = 4
  alignment140 _ = 4
  sizeOf140 = sizeOfPacked
  alignment430 = alignment140
  sizeOf430 = sizeOf140
  isStruct _ = False
  read140 = peekDiffOff
  write140 = pokeDiffOff
  read430 = read140
  write430 = write140
  readPacked = read140
  writePacked = write140
  {-# INLINE alignment140 #-}
  {-# INLINE sizeOf140 #-}
  {-# INLINE alignment430 #-}
  {-# INLINE sizeOf430 #-}
  {-# INLINE isStruct #-}
  {-# INLINE read140 #-}
  {-# INLINE write140 #-}
  {-# INLINE read430 #-}
  {-# INLINE write430 #-}
  {-# INLINE readPacked #-}
  {-# INLINE writePacked #-}

-- | Half-precision float (GLSL @float16_t@): a 2-byte scalar, base alignment 2.
instance Block Half where
  type PackedSize Half = 2
  alignment140 _ = 2
  sizeOf140 = sizeOfPacked
  alignment430 = alignment140
  sizeOf430 = sizeOf140
  isStruct _ = False
  read140 = peekDiffOff
  write140 = pokeDiffOff
  read430 = read140
  write430 = write140
  readPacked = read140
  writePacked = write140
  {-# INLINE alignment140 #-}
  {-# INLINE sizeOf140 #-}
  {-# INLINE alignment430 #-}
  {-# INLINE sizeOf430 #-}
  {-# INLINE isStruct #-}
  {-# INLINE read140 #-}
  {-# INLINE write140 #-}
  {-# INLINE read430 #-}
  {-# INLINE write430 #-}
  {-# INLINE readPacked #-}
  {-# INLINE writePacked #-}

instance Block Int64 where
  type PackedSize Int64 = 8
  alignment140 _ = 8
  sizeOf140 = sizeOfPacked
  alignment430 = alignment140
  sizeOf430 = sizeOf140
  isStruct _ = False
  read140 = peekDiffOff
  write140 = pokeDiffOff
  read430 = read140
  write430 = write140
  readPacked = read140
  writePacked = write140
  {-# INLINE alignment140 #-}
  {-# INLINE sizeOf140 #-}
  {-# INLINE alignment430 #-}
  {-# INLINE sizeOf430 #-}
  {-# INLINE isStruct #-}
  {-# INLINE read140 #-}
  {-# INLINE write140 #-}
  {-# INLINE read430 #-}
  {-# INLINE write430 #-}
  {-# INLINE readPacked #-}
  {-# INLINE writePacked #-}

instance Block Word64 where
  type PackedSize Word64 = 8
  alignment140 _ = 8
  sizeOf140 = sizeOfPacked
  alignment430 = alignment140
  sizeOf430 = sizeOf140
  isStruct _ = False
  read140 = peekDiffOff
  write140 = pokeDiffOff
  read430 = read140
  write430 = write140
  readPacked = read140
  writePacked = write140
  {-# INLINE alignment140 #-}
  {-# INLINE sizeOf140 #-}
  {-# INLINE alignment430 #-}
  {-# INLINE sizeOf430 #-}
  {-# INLINE isStruct #-}
  {-# INLINE read140 #-}
  {-# INLINE write140 #-}
  {-# INLINE read430 #-}
  {-# INLINE write430 #-}
  {-# INLINE readPacked #-}
  {-# INLINE writePacked #-}

instance Block Double where
  type PackedSize Double = 8
  alignment140 _ = 8
  sizeOf140 = sizeOfPacked
  alignment430 = alignment140
  sizeOf430 = sizeOf140
  isStruct _ = False
  read140 = peekDiffOff
  write140 = pokeDiffOff
  read430 = read140
  write430 = write140
  readPacked = read140
  writePacked = write140
  {-# INLINE alignment140 #-}
  {-# INLINE sizeOf140 #-}
  {-# INLINE alignment430 #-}
  {-# INLINE sizeOf430 #-}
  {-# INLINE isStruct #-}
  {-# INLINE read140 #-}
  {-# INLINE write140 #-}
  {-# INLINE read430 #-}
  {-# INLINE write430 #-}
  {-# INLINE readPacked #-}
  {-# INLINE writePacked #-}

instance Block CDouble where
  type PackedSize CDouble = 8
  alignment140 _ = 8
  sizeOf140 = sizeOfPacked
  alignment430 = alignment140
  sizeOf430 = sizeOf140
  isStruct _ = False
  read140 = peekDiffOff
  write140 = pokeDiffOff
  read430 = read140
  write430 = write140
  readPacked = read140
  writePacked = write140
  {-# INLINE alignment140 #-}
  {-# INLINE sizeOf140 #-}
  {-# INLINE alignment430 #-}
  {-# INLINE sizeOf430 #-}
  {-# INLINE isStruct #-}
  {-# INLINE read140 #-}
  {-# INLINE write140 #-}
  {-# INLINE read430 #-}
  {-# INLINE write430 #-}
  {-# INLINE readPacked #-}
  {-# INLINE writePacked #-}

{- | Reference layout for a fixed-size array member, per std140 rule 4

Both share one formula:
the array's base alignment is the element's rounded up to a vec4, and the
per-element stride is the element size padded to that alignment. std430 (the
rule 4\/9 relaxation) drops the vec4 rounding and keeps the element's own
alignment. A real instance needs a sized-vector element type (e.g. @linear@'s
@V n@), which this library does not depend on; see @Spec.Array@ (@Array n a@
over @Data.Vector.Storable@) in the test suite for a working implementation.
-}
{-
instance (Dim n, Block a) => Block (V n a) where
  isStruct _ = True -- an array member is always at least vec4-aligned in std140
  -- rule 4: round the element alignment up to a vec4 for scalar and vector
  -- elements too, not only structs (that omission was the original bug here).
  alignment140 _ = roundUp (alignment140 (Proxy :: Proxy a)) 16
  alignment430 _ = alignment430 (Proxy :: Proxy a)
  -- size = stride * length; the stride pads the element to the array alignment,
  -- so the whole array is an exact number of strides (no extra tail padding).
  sizeOf140 _ = roundUp (sizeOf140 (Proxy :: Proxy a)) (roundUp (alignment140 (Proxy :: Proxy a)) 16) * reflectDim (Proxy :: Proxy n)
  sizeOf430 _ = roundUp (sizeOf430 (Proxy :: Proxy a)) (alignment430 (Proxy :: Proxy a)) * reflectDim (Proxy :: Proxy n)
  read140 p (Diff o) = liftIO $ sequence $ tabulate \i -> read140 p $ Diff (o + i*d) where
    d = roundUp (sizeOf140 (Proxy :: Proxy a)) (roundUp (alignment140 (Proxy :: Proxy a)) 16)
  write140 p (Diff o) v = liftIO $ iforM_ v \i -> write140 p (Diff (o + i*d)) where
    d = roundUp (sizeOf140 (Proxy :: Proxy a)) (roundUp (alignment140 (Proxy :: Proxy a)) 16)
  read430 p (Diff o) = liftIO $ sequence $ tabulate \i -> read430 p $ Diff (o + i*d) where
    d = roundUp (sizeOf430 (Proxy :: Proxy a)) (alignment430 (Proxy :: Proxy a))
  write430 p (Diff o) v = liftIO $ iforM_ v \i -> write430 p (Diff (o + i*d)) where
    d = roundUp (sizeOf430 (Proxy :: Proxy a)) (alignment430 (Proxy :: Proxy a))
-}

-- | @roundUp k n@ rounds up k up to an integral multiple of n
roundUp :: Int -> Int -> Int
roundUp k n = k + mod (n - k) n
{-# INLINEABLE roundUp #-}

instance (Block a, Block b, KnownNat (PackedSize a + PackedSize b)) => Block (a, b)
instance (Block a, Block b, Block c, KnownNat (PackedSize a + (PackedSize b + PackedSize c))) => Block (a, b, c)