gl-block 1.0 → 1.1

raw patch · 12 files changed

+1323/−219 lines, 12 filesdep +halfsetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies added: half

API changes (from Hackage documentation)

Files

• ChangeLog.md +16/−0
• README.md +24/−24
• Setup.hs +0/−2
• bench/Bench.hs +28/−35
• bench/Bench/Struct.hs +40/−38
• gl-block.cabal +13/−4
• src/Graphics/Gl/Block.hs +433/−105
• test/Spec/Array.hs +203/−0
• test/Spec/Layout.hs +345/−0
• test/Spec/Layout/Golden.hs +42/−0
• test/Spec/Packed.hs +12/−11
• test/Spec/Types.hs +167/−0

@@ -0,0 +1,16 @@+## 1.1++- Fix gsizeOf140 for M1 C.+- Add some Foreign.C instances.+- Add `Block` instances for 16-bit scalars: `Word16`, `Int16`, `CShort`,+  `CUShort`, and `Half` (GLSL `float16_t`, via the `half` package).+- Fix generic struct layout: a low-alignment field followed by a+  higher-alignment field in the same (right-leaning) product subtree was+  over-padded — e.g. `data S = S Word16 Word16 Float` placed the second+  `Word16` at offset 4 instead of 2. Fields are now laid out by threading the+  running offset through each leaf and rounding to the leaf's own base+  alignment, matching glslang/spirv-cross.++## 1.0++Initial release, extracted from EKmett's codex/glow project.

@@ -58,32 +58,32 @@ ```python   struct     10-      manual: OK (2.26s)-        60.6 ns ± 5.4 ns-      packed: OK (1.21s)-        63.7 ns ± 5.8 ns-      std140: OK (1.19s)-        256  ns ±  26 ns-      std430: OK (0.13s)-        269  ns ±  24 ns+      manual: OK (0.36s)+        19.0 ns ± 1.9 ns, 325 B  allocated,   0 B  copied, 117 MB peak memory+      packed: OK (0.68s)+        18.5 ns ± 782 ps, 327 B  allocated,   0 B  copied, 117 MB peak memory, 0.98x+      std140: OK (0.58s)+        64.9 ns ± 4.0 ns, 827 B  allocated,   0 B  copied, 117 MB peak memory, 3.42x+      std430: OK (0.28s)+        62.1 ns ± 3.3 ns, 658 B  allocated,   0 B  copied, 117 MB peak memory, 3.28x     1000-      manual: OK (1.95s)-        3.34 μs ± 244 ns-      packed: OK (1.96s)-        3.34 μs ± 235 ns-      std140: OK (1.97s)-        6.70 μs ± 425 ns-      std430: OK (1.44s)-        4.89 μs ±  93 ns+      manual: OK (0.41s)+        334  ns ±  30 ns,  23 KB allocated,   0 B  copied, 135 MB peak memory+      packed: OK (0.40s)+        320  ns ±  23 ns,  23 KB allocated,   0 B  copied, 135 MB peak memory, 0.96x+      std140: OK (0.44s)+        733  ns ±  64 ns,  47 KB allocated,   0 B  copied, 137 MB peak memory, 2.19x+      std430: OK (0.55s)+        460  ns ±  30 ns,  32 KB allocated,   0 B  copied, 137 MB peak memory, 1.38x     1000000-      manual: OK (2.59s)-        2.22 ms ± 176 μs-      packed: OK (1.50s)-        2.47 ms ±  24 μs-      std140: OK (2.70s)-        4.54 ms ± 431 μs-      std430: OK (1.08s)-        3.28 ms ± 244 μs+      manual: OK (0.42s)+        344  μs ±  27 μs,  23 MB allocated, 167 B  copied, 141 MB peak memory+      packed: OK (0.42s)+        350  μs ±  14 μs,  23 MB allocated, 164 B  copied, 141 MB peak memory, 1.02x+      std140: OK (0.92s)+        817  μs ±  36 μs,  46 MB allocated, 241 B  copied, 163 MB peak memory, 2.38x+      std430: OK (1.20s)+        523  μs ±  20 μs,  30 MB allocated, 157 B  copied, 164 MB peak memory, 1.52x ```  > Caveat: nested structures have degraded performance.

@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain

@@ -1,42 +1,35 @@ {-# LANGUAGE ImportQualifiedPost #-} -import Test.Tasty.Bench (bench, bgroup, defaultMain, nf)+import Test.Tasty.Bench (Benchmark, bcompare, bench, bgroup, defaultMain, nf)  import Bench.Struct import Data.Vector.Storable qualified as Storable  main :: IO ()-main = defaultMain-  [ bgroup "struct"-      [ bgroup "10"-          [ bench "manual" $-              nf (flip Storable.replicate structManual) 10-          , bench "packed" $-              nf (flip Storable.replicate structPacked) 10-          , bench "std140" $-              nf (flip Storable.replicate struct140) 10-          , bench "std430" $-              nf (flip Storable.replicate struct430) 10-          ]-      , bgroup "1000"-          [ bench "manual" $-              nf (flip Storable.replicate structManual) 1000-          , bench "packed" $-              nf (flip Storable.replicate structPacked) 1000-          , bench "std140" $-              nf (flip Storable.replicate struct140) 1000-          , bench "std430" $-              nf (flip Storable.replicate struct430) 1000-          ]-      , bgroup "1000000"-          [ bench "manual" $-              nf (flip Storable.replicate structManual) 1000000-          , bench "packed" $-              nf (flip Storable.replicate structPacked) 1000000-          , bench "std140" $-              nf (flip Storable.replicate struct140) 1000000-          , bench "std430" $-              nf (flip Storable.replicate struct430) 1000000-          ]-      ]-  ]+main =+  defaultMain+    [ bgroup+        "struct"+        [ sizes "10" 10+        , sizes "1000" 1000+        , sizes "1000000" 1000000+        ]+    ]++sizes :: String -> Int -> Benchmark+sizes name n =+  bgroup+    name+    [ bench "manual" $+        nf (`Storable.replicate` structManual) n+    , vsManual "packed" $+        nf (`Storable.replicate` structPacked) n+    , vsManual "std140" $+        nf (`Storable.replicate` struct140) n+    , vsManual "std430" $+        nf (`Storable.replicate` struct430) n+    ]+  where+    vsManual label =+      bcompare ("$NF == \"manual\" && $(NF-1) == \"" <> name <> "\"")+        . bench label

@@ -1,18 +1,17 @@-{-# LANGUAGE Strict #-}- {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE Strict #-}  module Bench.Struct where  import Foreign import GHC.Generics (Generic) -import Graphics.Gl.Block (Block, Packed(..), Std140(..), Std430(..))+import Graphics.Gl.Block (Block, Packed (..), Std140 (..), Std430 (..))  data StructManual = StructManual   { smWat :: Bool -- 4@@ -23,12 +22,13 @@   deriving stock (Eq, Ord, Show, Generic)  structManual :: StructManual-structManual = StructManual-  { smWat = True-  , smThis = 2 * pi-  , smThat = pi-  , smThose = (1/60, -1e6)-  }+structManual =+  StructManual+    { smWat = True+    , smThis = 2 * pi+    , smThat = pi+    , smThose = (1 / 60, -1e6)+    }  instance Storable StructManual where   alignment ~_ = 8@@ -38,11 +38,10 @@       <$> peekByteOff ptr 0       <*> peekByteOff ptr 4       <*> peekByteOff ptr 12-      <*> (-        (,)-          <$> peekByteOff ptr 16-          <*> peekByteOff ptr 20-      )+      <*> ( (,)+              <$> peekByteOff ptr 16+              <*> peekByteOff ptr 20+          )   poke ptr StructManual{..} = do     pokeByteOff ptr 0 smWat     pokeByteOff ptr 4 smThis@@ -57,16 +56,17 @@   , spThose :: (Float, Float) -- 4 + 4   }   deriving stock (Eq, Ord, Show, Generic)-  deriving anyclass Block-  deriving Storable via (Packed StructPacked)+  deriving anyclass (Block)+  deriving (Storable) via (Packed StructPacked)  structPacked :: StructPacked-structPacked = StructPacked-  { spWat = True-  , spThis = 2 * pi-  , spThat = pi-  , spThose = (1/60, -1e6)-  }+structPacked =+  StructPacked+    { spWat = True+    , spThis = 2 * pi+    , spThat = pi+    , spThose = (1 / 60, -1e6)+    }  data Struct140 = Struct140   { std140Wat :: Bool -- 4@@ -75,16 +75,17 @@   , std140Those :: (Float, Float) -- 4 + 4   }   deriving stock (Eq, Ord, Show, Generic)-  deriving anyclass Block-  deriving Storable via (Std140 Struct140)+  deriving anyclass (Block)+  deriving (Storable) via (Std140 Struct140)  struct140 :: Struct140-struct140 = Struct140-  { std140Wat = True-  , std140This = 2 * pi-  , std140That = pi-  , std140Those = (1/60, -1e6)-  }+struct140 =+  Struct140+    { std140Wat = True+    , std140This = 2 * pi+    , std140That = pi+    , std140Those = (1 / 60, -1e6)+    }  data Struct430 = Struct430   { std430Wat :: Bool -- 4@@ -93,13 +94,14 @@   , std430Those :: (Float, Float) -- 4 + 4   }   deriving stock (Eq, Ord, Show, Generic)-  deriving anyclass Block-  deriving Storable via (Std430 Struct430)+  deriving anyclass (Block)+  deriving (Storable) via (Std430 Struct430)  struct430 :: Struct430-struct430 = Struct430-  { std430Wat = True-  , std430This = 2 * pi-  , std430That = pi-  , std430Those = (1/60, -1e6)-  }+struct430 =+  Struct430+    { std430Wat = True+    , std430This = 2 * pi+    , std430That = pi+    , std430Those = (1 / 60, -1e6)+    }

@@ -1,21 +1,22 @@ cabal-version: 2.2 --- This file has been generated from package.yaml by hpack version 0.35.2.+-- This file has been generated from package.yaml by hpack version 0.39.1. -- -- see: https://github.com/sol/hpack  name:           gl-block-version:        1.0+version:        1.1 synopsis:       OpenGL standard memory layouts category:       Graphics author:         IC Rainbow maintainer:     ic.rbow@gmail.com-copyright:      2023 IC Rainbow, 2014-2019 Edward Kmett+copyright:      2023-2026 IC Rainbow, 2014-2019 Edward Kmett license:        (BSD-2-Clause OR Apache-2.0) license-file:   LICENSE build-type:     Simple extra-source-files:     README.md+extra-doc-files:     ChangeLog.md  source-repository head@@ -34,6 +35,7 @@   ghc-options: -Wall   build-depends:       base >=4.7 && <5+    , half     , ptrdiff   default-language: Haskell2010 @@ -41,7 +43,11 @@   type: exitcode-stdio-1.0   main-is: Spec.hs   other-modules:+      Spec.Array+      Spec.Layout+      Spec.Layout.Golden       Spec.Packed+      Spec.Types       Paths_gl_block   autogen-modules:       Paths_gl_block@@ -53,8 +59,11 @@   build-depends:       base >=4.7 && <5     , gl-block+    , half+    , ptrdiff     , tasty     , tasty-hunit+    , vector   default-language: Haskell2010  benchmark gl-block-bench@@ -67,7 +76,7 @@       Paths_gl_block   hs-source-dirs:       bench-  ghc-options: -Wall -O2 -threaded -rtsopts -with-rtsopts=-N1 -fproc-alignment=64 -with-rtsopts=-A128m+  ghc-options: -Wall -O2 -threaded -rtsopts -fproc-alignment=64 "-with-rtsopts=-N1 -A64m -T"   build-depends:       base >=4.7 && <5     , gl-block

@@ -12,8 +12,8 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -{- |-Copyright:  (c) 2023 IC Rainbow+{-|+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>@@ -23,95 +23,98 @@ OpenGL std140 and std430 support -} module Graphics.Gl.Block-  ( Block(..)-  , GBlock(..)-  , Packed(..)-  , Std140(..)-  , Std430(..)+  ( Block (..)+  , GBlock (..)+  , Packed (..)+  , Std140 (..)+  , Std430 (..)   , roundUp   ) where -import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.IO.Class (MonadIO (..)) import Data.Data (Data, Typeable)-import Data.Int (Int32)-import Data.Proxy (Proxy(..))-import Data.Word (Word32)+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 (Generic, Rep, M1(..), K1(..), U1(..), C, D, S, (:*:)(..), from, to)-import GHC.TypeLits (KnownNat, Nat, type (+), natVal)+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 }+newtype Packed a = Packed {getPacked :: a}   deriving (Data, Typeable, Generic, Functor, Foldable, Traversable, Eq, Ord, Show, Read) -instance Block a => Storable (Packed a) where+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 }+newtype Std140 a = Std140 {getStd140 :: a}   deriving (Data, Typeable, Generic, Functor, Foldable, Traversable, Eq, Ord, Show, Read) -instance Block a => Storable (Std140 a) where+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 }+newtype Std430 a = Std430 {getStd430 :: a}   deriving (Data, Typeable, Generic, Functor, Foldable, Traversable, Eq, Ord, Show, Read) -instance Block a => Storable (Std430 a) where+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.+{- | 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+  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+  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+  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 ()+  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+  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+  default sizeOf430 :: (GBlock (Rep b)) => proxy b -> Int   sizeOf430 _ = gsizeOf430 (Proxy :: Proxy (Rep b)) -  read430 :: MonadIO m => Ptr a -> Diff a b -> m 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 ()+  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) @@ -120,39 +123,67 @@    -- | As per 'Storable' 'sizeOf', but without padding and no alignment   sizeOfPacked :: proxy b -> Int-  default sizeOfPacked :: KnownNat (PackedSize b) => 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+  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 ()+  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+  galignment140 :: p f -> Int+  galignment430 :: p f -> Int+  gsizeOf140 :: p f -> Int+  gsizeOf430 :: p f -> Int   gsizeOfPacked :: p f -> Int-  gread140    :: Ptr a -> Int -> IO (f b)-  gread430    :: Ptr a -> Int -> IO (f b)++  {- | 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 ()+  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+  gsizeOf140 _ = 0   galignment430 _ = 1-  gsizeOf430    _ = 0-  gsizeOfPacked    _ = 0+  gsizeOf430 _ = 0+  gsizeOfPacked _ = 0+  gnextOffset140 _ o = o+  gnextOffset430 _ o = o   gread140 _ _ = return U1   gread430 _ _ = return U1   greadPacked _ _ = return U1@@ -176,49 +207,50 @@       (galignment430 (Proxy :: Proxy f))       (galignment430 (Proxy :: Proxy g)) -  gsizeOf140 _ =-    roundUp-      (gsizeOf140 (Proxy :: Proxy f))-      (galignment140 (Proxy :: Proxy g))-    + gsizeOf140 (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 -  gsizeOf430 _ =-    roundUp-      (gsizeOf430 (Proxy :: Proxy f))-      (galignment430 (Proxy :: Proxy g))-    + gsizeOf430 (Proxy :: Proxy g)+  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 (o + roundUp (gsizeOf140 (Proxy :: Proxy f)) (galignment140 (Proxy :: Proxy g)))+  gread140 p o =+    (:*:)+      <$> gread140 p o+      <*> gread140 p (gnextOffset140 (Proxy :: Proxy f) o) -  gread430 p o = (:*:)-    <$> gread430 p o-    <*> gread430 p (o + roundUp (gsizeOf430 (Proxy :: Proxy f)) (galignment430 (Proxy :: Proxy g)))+  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))+  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 (o + roundUp (gsizeOf140 (Proxy :: Proxy f)) (galignment140 (Proxy :: Proxy g))) b+    gwrite140 p (gnextOffset140 (Proxy :: Proxy f) o) b    gwrite430 p o (a :*: b) = do     gwrite430 p o a-    gwrite430 p (o + roundUp (gsizeOf430 (Proxy :: Proxy f)) (galignment430 (Proxy :: Proxy g))) b+    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+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)+  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@@ -226,13 +258,17 @@   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+instance (GBlock f) => GBlock (M1 C c f) where   type GPackedSize (M1 C c f) = GPackedSize f-  galignment140 _ = lcm 16 $ galignment140 (Proxy :: Proxy f) -- std140 rule 9+  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)) (galignment140 (Proxy :: Proxy f)) -- std140 rule 9-  gsizeOf430    _ = roundUp (gsizeOf430 (Proxy :: Proxy f)) (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@@ -240,13 +276,15 @@   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+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)+  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@@ -254,18 +292,20 @@   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+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)+  gsizeOf140 _ = sizeOf140 (Proxy :: Proxy c)+  gsizeOf430 _ = sizeOf430 (Proxy :: Proxy c)   gsizeOfPacked _ = sizeOfPacked (Proxy :: Proxy c)-  gread140 p o = K1 <$> read140 p (Diff o)-  gread430 p o = K1 <$> read430 p (Diff o)+  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 o) a-  gwrite430 p o (K1 a) = write430 p (Diff o) a+  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@@ -301,6 +341,106 @@   {-# 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@@ -326,6 +466,31 @@   {-# 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@@ -351,6 +516,31 @@   {-# 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@@ -376,6 +566,107 @@   {-# 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@@ -387,7 +678,7 @@   write140 = pokeDiffOff   read430 = read140   write430 = write140-  readPacked  = read140+  readPacked = read140   writePacked = write140   {-# INLINE alignment140 #-}   {-# INLINE sizeOf140 #-}@@ -401,24 +692,61 @@   {-# INLINE readPacked #-}   {-# INLINE writePacked #-} --- -- | Can be used for fixed-sized arrays--- instance (Dim n, Block a) => Block (V n a) where---   isStruct _ = isStruct (Proxy :: Proxy a)---   alignment140 _---     | isStruct (Proxy :: Proxy a) = lcm 16 n -- std140 rule 9---     | otherwise = n---     where n = alignment140 (Proxy :: Proxy a)---   alignment430 _ = alignment430 (Proxy :: Proxy a)---   sizeOf140 _ = roundUp (sizeOf140 (Proxy :: Proxy a)) (alignment140 (Proxy :: Proxy a)) * 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)) (alignment140 (Proxy :: Proxy a))---   write140 p (Diff o) v = liftIO $ iforM_ v \i -> write140 p (Diff (o + i*d)) where---     d = roundUp (sizeOf140 (Proxy :: Proxy a)) (alignment140 (Proxy :: Proxy a))---   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))+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

@@ -0,0 +1,203 @@+-- These extensions are not in the package-wide default-extensions.+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ExplicitNamespaces #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++{-| A fixed-length array suitable as a std140\/std430 block /field/.++@'Array' n a@ is @n@ elements of @a@ laid out as an array member: each element+occupies a layout-dependent stride (std140 rounds the element stride up to a+multiple of 16; std430 packs to the element's own alignment). The element type's+'Block' instance does the per-element encoding, so anything that is a 'Block' (a+scalar, a vector, or a generated struct record) can be the element.++The backing 'VS.Vector' should hold exactly @n@ elements; 'write140' \/ 'write430'+write the first @n@ and ignore any extra (so a buffer is never overrun).+-}+module Spec.Array+  ( Array (..)+  , unsafeFromList+  , toList++    -- * Runtime-sized arrays+    -- $runtime+  , std140Stride+  , std430Stride+  , pokeStd140+  , pokeStd430+  , peekStd140+  , peekStd430+  ) where++import Control.Monad.IO.Class (MonadIO (..))+import Data.Proxy (Proxy (..))+import Data.Vector.Storable qualified as VS+import Foreign.Ptr (Ptr, castPtr)+import Foreign.Ptr.Diff (Diff (..))+import Foreign.Storable (Storable (..))+import GHC.TypeNats (KnownNat, Nat, natVal)+import GHC.TypeNats qualified as TN+import Graphics.Gl.Block (Block (..), roundUp)++-- | @n@ elements of @a@, laid out as an array block member.+newtype Array (n :: Nat) a = Array (VS.Vector a)++deriving instance (Storable a, Eq a) => Eq (Array n a)+deriving instance (Storable a, Show a) => Show (Array n a)++-- | Build an 'Array' from a list (should be @n@ elements long).+{-# INLINE unsafeFromList #-}+unsafeFromList :: forall n a. (KnownNat n, Storable a) => [a] -> Array n a+unsafeFromList = Array . VS.fromListN (count (Proxy @n))++-- | The elements of an 'Array' as a list.+toList :: (Storable a) => Array n a -> [a]+toList (Array v) = VS.toList v++{- | A tight, host-side 'Storable' (n contiguous elements). This is unrelated to+the gl-block layout below — it only lets an 'Array' nest as the element of+another 'Array' (multi-dimensional arrays: @'Array' h ('Array' w a)@).+-}+instance (KnownNat n, Storable a) => Storable (Array n a) where+  sizeOf _ = count (Proxy @n) * sizeOf (undefined :: a)+  alignment _ = alignment (undefined :: a)+  peek ptr = Array <$> VS.generateM (count (Proxy @n)) (peekElemOff (castPtr ptr))+  poke ptr (Array v) = VS.imapM_ (pokeElemOff (castPtr ptr)) (VS.take (count (Proxy @n)) v)++instance (KnownNat n, Block a, Storable a) => Block (Array n a) where+  type PackedSize (Array n a) = n TN.* PackedSize a++  isStruct _ = True++  alignment140 _ = roundUp (alignment140 (Proxy @a)) 16+  alignment430 _ = alignment430 (Proxy @a)++  sizeOf140 _ = count (Proxy @n) * std140Stride (Proxy @a)+  sizeOf430 _ = count (Proxy @n) * std430Stride (Proxy @a)+  sizeOfPacked _ = count (Proxy @n) * sizeOfPacked (Proxy @a)++  read140 = readArrayWith (count (Proxy @n)) (std140Stride (Proxy @a)) read140+  read430 = readArrayWith (count (Proxy @n)) (std430Stride (Proxy @a)) read430+  readPacked = readArrayWith (count (Proxy @n)) (sizeOfPacked (Proxy @a)) readPacked++  write140 = writeArrayWith (count (Proxy @n)) (std140Stride (Proxy @a)) write140+  write430 = writeArrayWith (count (Proxy @n)) (std430Stride (Proxy @a)) write430+  writePacked = writeArrayWith (count (Proxy @n)) (sizeOfPacked (Proxy @a)) writePacked+  {-# INLINE alignment140 #-}+  {-# INLINE alignment430 #-}+  {-# INLINE isStruct #-}+  {-# INLINE read140 #-}+  {-# INLINE read430 #-}+  {-# INLINE readPacked #-}+  {-# INLINE sizeOf140 #-}+  {-# INLINE sizeOf430 #-}+  {-# INLINE write140 #-}+  {-# INLINE write430 #-}+  {-# INLINE writePacked #-}++{-# INLINE count #-}+count :: (KnownNat n) => Proxy n -> Int+count = fromIntegral . natVal++{- | Per-element stride for an array member: std140 rounds the element size up to+a multiple of 16.+-}+std140Stride :: (Block a) => Proxy a -> Int+std140Stride p = roundUp (sizeOf140 p) (roundUp (alignment140 p) 16)++{- | Per-element stride for an array member: std430 packs to the element's own+base alignment.+-}+std430Stride :: (Block a) => Proxy a -> Int+std430Stride p = roundUp (sizeOf430 p) (alignment430 p)++{- $runtime+A runtime-sized array (the trailing @T[]@ of a storage buffer) has no+compile-time length, so it is /not/ a fixed-size 'Block' and is represented+directly as a @'VS.Vector' a@. These helpers (de)serialize such a vector at the+layout's element stride, using the element's own 'Block' instance — so an element+whose array stride differs from its packed size (e.g. a @vec3@, or a struct+padded up to its alignment) is still placed correctly. The 'Ptr' should point at+the start of the array (for a buffer whose only contents are the array, that is+the mapped base pointer).+-}++-- | Write a runtime-length array of std140 elements starting at @ptr@.+{-# INLINE pokeStd140 #-}+pokeStd140 :: forall a x m. (Block a, Storable a, MonadIO m) => Ptr x -> VS.Vector a -> m ()+pokeStd140 = pokeArrayAt (std140Stride (Proxy @a)) write140++-- | Write a runtime-length array of std430 elements starting at @ptr@.+{-# INLINE pokeStd430 #-}+pokeStd430 :: forall a x m. (Block a, Storable a, MonadIO m) => Ptr x -> VS.Vector a -> m ()+pokeStd430 = pokeArrayAt (std430Stride (Proxy @a)) write430++-- | Read @n@ std140 elements starting at @ptr@.+{-# INLINE peekStd140 #-}+peekStd140 :: forall a x m. (Block a, Storable a, MonadIO m) => Int -> Ptr x -> m (VS.Vector a)+peekStd140 = peekArrayAt (std140Stride (Proxy @a)) read140++-- | Read @n@ std430 elements starting at @ptr@.+{-# INLINE peekStd430 #-}+peekStd430 :: forall a x m. (Block a, Storable a, MonadIO m) => Int -> Ptr x -> m (VS.Vector a)+peekStd430 = peekArrayAt (std430Stride (Proxy @a)) read430++{-# INLINE pokeArrayAt #-}+pokeArrayAt+  :: (Storable a, MonadIO m)+  => Int+  -> (Ptr x -> Diff x a -> a -> IO ())+  -> Ptr x+  -> VS.Vector a+  -> m ()+pokeArrayAt stride wr ptr v =+  liftIO $ VS.imapM_ (\i x -> wr ptr (Diff (i * stride)) x) v++{-# INLINE peekArrayAt #-}+peekArrayAt+  :: (Storable a, MonadIO m)+  => Int+  -> (Ptr x -> Diff x a -> IO a)+  -> Int+  -> Ptr x+  -> m (VS.Vector a)+peekArrayAt stride rd n ptr =+  liftIO $ VS.generateM n (\i -> rd ptr (Diff (i * stride)))++{-# INLINE readArrayWith #-}+readArrayWith+  :: (Storable a, MonadIO m)+  => Int+  -- ^ element count+  -> Int+  -- ^ element stride+  -> (Ptr x -> Diff x a -> IO a)+  -- ^ element reader+  -> Ptr x+  -> Diff x (Array n a)+  -> m (Array n a)+readArrayWith n stride rd ptr (Diff o) =+  liftIO $ Array <$> VS.generateM n (\i -> rd ptr (Diff (o + i * stride)))++{-# INLINE writeArrayWith #-}+writeArrayWith+  :: (Storable a, MonadIO m)+  => Int+  -- ^ element count+  -> Int+  -- ^ element stride+  -> (Ptr x -> Diff x a -> a -> IO ())+  -- ^ element writer+  -> Ptr x+  -> Diff x (Array n a)+  -> Array n a+  -> m ()+writeArrayWith n stride wr ptr (Diff o) (Array v) =+  liftIO $ VS.imapM_ (\i x -> wr ptr (Diff (o + i * stride)) x) (VS.take n v)

@@ -0,0 +1,345 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE ScopedTypeVariables #-}++{-| Cross-checks gl-block's std140/std430 layout against the reference+produced by glslangValidator + spirv-cross (see test/tools/gen-goldens.py).++For each corpus struct we poke the real 'Std140'/'Std430' 'Storable' into a+buffer twice: once over 0x00 fill, once over 0xFF fill. A byte was written+by gl-block iff the two results agree (untouched bytes keep their differing+fill), so we recover the exact set of occupied bytes without depending on+the field values -- which also handles 'Bool' serialising as 0x00000001.+That occupancy and the buffer size must match the reference reflection.+-}+module Spec.Layout where++import Control.Exception (SomeException, try)+import Data.List (nub, sort)+import Foreign+import Foreign.C.Types (CDouble, CFloat, CInt, CShort, CUInt, CUShort)+import GHC.Generics (Generic)+import Numeric.Half (Half)++import Graphics.Gl.Block (Block, Packed (..), Std140 (..), Std430 (..))+import Spec.Array (Array, unsafeFromList)+import Spec.Layout.Golden (Layout (..), goldens)+import Spec.Types (Mat4 (..), Vec2 (..), Vec3 (..), Vec3Packed (..), Vec4 (..))++import Test.Tasty+import Test.Tasty.HUnit++-- Corpus: every type mirrors a test/glsl/*.glslfrag struct, field for field.++data Scalars = Scalars Int32 Word32 Float+  deriving stock (Eq, Show, Generic)+  deriving anyclass (Block)++data Doubles = Doubles Float Double Float+  deriving stock (Eq, Show, Generic)+  deriving anyclass (Block)++data Wide64 = Wide64 Word32 Int64 Float Word64+  deriving stock (Eq, Show, Generic)+  deriving anyclass (Block)++{- | @those@ is a tuple, so gl-block lays it out as the @struct Pair@ in+Mixed.glslfrag (not a vec2). @wat@ is a 'Bool' against GLSL @uint@.+-}+data Mixed = Mixed Bool Double Float (Float, Float)+  deriving stock (Eq, Show, Generic)+  deriving anyclass (Block)++data Nested2 = Nested2 (Float, Double) Float+  deriving stock (Eq, Show, Generic)+  deriving anyclass (Block)++{- | A 4-aligned sub-struct followed by a scalar: isolates whether a nested+struct's std140 size is padded up to 16 (which sets @b@'s offset).+-}+data NestPad = NestPad (Float, Float) Float+  deriving stock (Eq, Show, Generic)+  deriving anyclass (Block)++-- | Foreign.C.Types scalars, to cover the @C*@ 'Block' instances.+data CTypes = CTypes CInt CUInt CFloat CDouble+  deriving stock (Eq, Show, Generic)+  deriving anyclass (Block)++{- | 16-bit integer scalars. @c@ (a 4-byte @uint@) follows two 2-byte fields, so+the reference packs @a\/b@ tight (alignment 2) and only then bumps @c@ to a+4-byte boundary -- this pins that a tail field of higher alignment doesn't+over-pad the 16-bit fields before it.+-}+data Shorts16 = Shorts16 Word16 Int16 Word32 Word16+  deriving stock (Eq, Show, Generic)+  deriving anyclass (Block)++-- | The @Foreign.C.Types@ 16-bit family (@CShort@/@CUShort@).+data CShorts16 = CShorts16 CShort CUShort Float+  deriving stock (Eq, Show, Generic)+  deriving anyclass (Block)++{- | A fixed-size 16-bit array: std140 rounds each element's stride up to 16+(64 bytes for 4 elements), while std430 packs them tight (8 bytes).+-}+data ShortArr = ShortArr (Array 4 Word16)+  deriving stock (Eq, Show, Generic)+  deriving anyclass (Block)++{- | Half-precision floats (GLSL @float16_t@). Two 2-byte halves pack tight, then+the 32-bit @c@ bumps to a 4-byte boundary -- same shape as 'CShorts16'.+-}+data Halves = Halves Half Half Float+  deriving stock (Eq, Show, Generic)+  deriving anyclass (Block)++-- | A fixed-size half-precision array (std140 element stride rounds up to 16).+data HalfArr = HalfArr (Array 4 Half)+  deriving stock (Eq, Show, Generic)+  deriving anyclass (Block)++{- | A record (named fields). Same 'Generic' 'Rep' as the positional product, so+it must lay out identically -- this is what locks that in.+-}+data Recordy = Recordy {rA :: Float, rB :: Double, rC :: Int32}+  deriving stock (Eq, Show, Generic)+  deriving anyclass (Block)++-- | A fixed-size array field (std140 rounds each element's stride up to 16).+data FloatArr = FloatArr (Array 4 Float)+  deriving stock (Eq, Show, Generic)+  deriving anyclass (Block)++-- | A scalar followed by a fixed-size array.+data MixArr = MixArr Float (Array 3 Float)+  deriving stock (Eq, Show, Generic)+  deriving anyclass (Block)++{- | A nullary constructor (size 0): exercises the @U1@ generic instance.+Not in the glslang corpus (an empty block isn't valid GLSL) -- round-trip only.+-}+data Unit0 = Unit0+  deriving stock (Eq, Show, Generic)+  deriving anyclass (Block)++-- | Names must match the @goldens@ keys (checked by 'unit_corpusMatchesGoldens').+data Some = forall a. (Block a, Eq a, Show a) => Some a++corpus :: [(String, Some)]+corpus =+  [ ("Scalars", Some (Scalars 1 2 3))+  , ("Doubles", Some (Doubles 1 2 3))+  , ("Wide64", Some (Wide64 1 2 3 4))+  , ("Mixed", Some (Mixed True 1 2 (3, 4)))+  , ("Nested2", Some (Nested2 (1, 2) 3))+  , ("NestPad", Some (NestPad (1, 2) 3))+  , ("CTypes", Some (CTypes 1 2 3 4))+  , ("Shorts16", Some (Shorts16 1 2 3 4))+  , ("CShorts16", Some (CShorts16 1 2 3))+  , ("ShortArr", Some (ShortArr (unsafeFromList [1, 2, 3, 4])))+  , ("Halves", Some (Halves 1 2 3))+  , ("HalfArr", Some (HalfArr (unsafeFromList [1, 2, 3, 4])))+  , ("Recordy", Some (Recordy 1 2 3))+  , ("FloatArr", Some (FloatArr (unsafeFromList [1, 2, 3, 4])))+  , ("MixArr", Some (MixArr 1 (unsafeFromList [2, 3, 4])))+  ]++-- | The set of bytes gl-block actually writes, via the two-fill trick.+occupiedMask :: (Storable w) => w -> IO [Bool]+occupiedMask w = do+  let n = sizeOf w+  allocaBytes n $ \p0 -> allocaBytes n $ \pF -> do+    fillBytes p0 0x00 n+    fillBytes pF 0xFF n+    poke (castPtr p0 :: Ptr w) w+    poke (castPtr pF :: Ptr w) w+    b0 <- peekArray n (p0 :: Ptr Word8)+    bF <- peekArray n (pF :: Ptr Word8)+    pure (zipWith (==) b0 bF)++-- | Bytes covered by the reference's scalar leaves, over a buffer of @stride@.+goldenMask :: Layout -> [Bool]+goldenMask lay =+  [ any (\(o, s) -> o <= i && i < o + s) (gLeaves lay)+  | i <- [0 .. gStride lay - 1]+  ]++{- | Collapse a byte mask to @(offset, length)@ runs -- a faithful, readable+encoding of the mask for assertion messages.+-}+runs :: [Bool] -> [(Int, Int)]+runs = go 0+  where+    go _ [] = []+    go i bs =+      let+        (gap, rest) = span not bs+        i' = i + length gap+        (run, rest') = span id rest+      in+        if null run then+          []+        else+          (i', length run) : go (i' + length run) rest'++checkLayout :: (Storable w) => Layout -> w -> Assertion+checkLayout lay w = do+  assertEqual "padded size (array stride)" (gStride lay) (sizeOf w)+  mask <- occupiedMask w+  assertEqual+    "occupied byte ranges (offset, length)"+    (runs (goldenMask lay))+    (runs mask)++{- | poke-then-peek must recover the value, for every layout. This is what+exercises the read side (read140\/read430\/readPacked and the generic struct+traversal), plus the packed size\/write paths.+-}+roundTrip :: (Block a, Eq a, Show a) => a -> Assertion+roundTrip v = do+  Std140 v140 <- with (Std140 v) peek+  v140 @?= v+  Std430 v430 <- with (Std430 v) peek+  v430 @?= v+  Packed vP <- with (Packed v) peek+  vP @?= v++test_layout :: TestTree+test_layout = testGroup "layout vs glslang/spirv-cross" (map perStruct corpus)+  where+    perStruct (name, Some a) =+      case lookup3 name goldens of+        Nothing -> testCase name $ assertFailure ("no golden for " ++ name)+        Just (g140, g430) ->+          testGroup+            name+            [ testCase "std140" $ checkLayout g140 (Std140 a)+            , testCase "std430" $ checkLayout g430 (Std430 a)+            , testCase "roundtrip" $ roundTrip a+            ]++lookup3 :: String -> [(String, b, c)] -> Maybe (b, c)+lookup3 k xs = case [(b, c) | (n, b, c) <- xs, n == k] of+  (x : _) -> Just x+  [] -> Nothing++-- | Guards against the corpus and the generated goldens drifting apart.+unit_corpusMatchesGoldens :: Assertion+unit_corpusMatchesGoldens =+  sort (nub (map fst corpus ++ [g | GCase _ g _ _ <- geomCases]))+    @?= sort [name | (name, _, _) <- goldens]++-- | A zero-field block round-trips (and its size is 0).+unit_emptyBlock :: Assertion+unit_emptyBlock = do+  sizeOf (Std140 Unit0) @?= 0+  roundTrip Unit0++-- | Covers the 3-tuple 'Block' instance (the corpus only uses 2-tuples).+unit_tuple3 :: Assertion+unit_tuple3 = roundTrip ((1, 2, 3) :: (Float, Float, Float))++-- Wrapper structs, mirroring the test/glsl/{Vecs,MatVec,Vec3Tail,Vec3Pack}.glslfrag.++data Vecs = Vecs Vec2 Vec3Packed Vec4+  deriving stock (Eq, Show, Generic)+  deriving anyclass (Block)++data MatVec = MatVec Mat4 Vec4+  deriving stock (Eq, Show, Generic)+  deriving anyclass (Block)++data Vec3TailP = Vec3TailP Float Vec3Packed+  deriving stock (Eq, Show, Generic)+  deriving anyclass (Block)++data Vec3TailD = Vec3TailD Float Vec3+  deriving stock (Eq, Show, Generic)+  deriving anyclass (Block)++data Vec3PackS = Vec3PackS Vec3Packed Float+  deriving stock (Eq, Show, Generic)+  deriving anyclass (Block)++{- | @float float vec2@: a low-alignment field (float, align 4) precedes a+higher-alignment sibling (vec2, align 8) in the same right-leaning product+subtree -- the same shape that over-padded 'CShorts16'\/'Halves'. The second+float must stay at offset 4, not be bumped to 8.+-}+data Vec2Tail = Vec2Tail Float Float Vec2+  deriving stock (Eq, Show, Generic)+  deriving anyclass (Block)++-- | Whether a specimen is expected to match glslang, or to diverge (and why).+data Mode = Conform | Diverges String++-- | (case label, golden key, mode, value)+data GCase = forall a. (Block a, Eq a, Show a) => GCase String String Mode a++geomCases :: [GCase]+geomCases =+  [ GCase+      "Vecs"+      "Vecs"+      Conform+      (Vecs (Vec2 1 2) (Vec3Packed (Vec3 3 4 5)) (Vec4 6 7 8 9))+  , GCase+      "MatVec"+      "MatVec"+      Conform+      (MatVec (Mat4 [1 .. 16]) (Vec4 1 2 3 4))+  , GCase+      "Vec3Tail (packed)"+      "Vec3Tail"+      Conform+      (Vec3TailP 1 (Vec3Packed (Vec3 2 3 4)))+  , GCase+      "Vec3Tail (default, writes 4th lane)"+      "Vec3Tail"+      (Diverges "default Vec3 writes its 4th lane (1.0): 16 occupied bytes vs the spec's 12")+      (Vec3TailD 1 (Vec3 2 3 4))+  , GCase+      "Vec3Pack (no vec3+scalar packing)"+      "Vec3Pack"+      (Diverges "sizeOf140(vec3)=16, so a vec3+scalar does not pack (glslang places the scalar at 12)")+      (Vec3PackS (Vec3Packed (Vec3 1 2 3)) 4)+  , GCase+      "Vec2Tail (float float vec2)"+      "Vec2Tail"+      Conform+      (Vec2Tail 1 2 (Vec2 3 4))+  ]++-- | Passes iff @act@ fails, i.e. gl-block diverges from glslang as expected.+expectMismatch :: String -> Assertion -> Assertion+expectMismatch why act = do+  res <- try act+  case res of+    Left (_ :: SomeException) -> pure ()+    Right () ->+      assertFailure+        ( "expected a known divergence ("+            ++ why+            ++ ") but gl-block now matches glslang -- promote this case"+        )++test_layoutGeom :: TestTree+test_layoutGeom =+  testGroup "geomancy vec/mat specimens vs glslang" (map perCase geomCases)+  where+    perCase (GCase name gname mode a) =+      case lookup3 gname goldens of+        Nothing -> testCase name $ assertFailure ("no golden for " ++ gname)+        Just (g140, g430) ->+          testGroup+            name+            [ testCase "std140" $ run mode g140 (Std140 a)+            , testCase "std430" $ run mode g430 (Std430 a)+            , testCase "roundtrip" $ roundTrip a+            ]+    run Conform lay w = checkLayout lay w+    run (Diverges why) lay w = expectMismatch why (checkLayout lay w)

@@ -0,0 +1,42 @@+{-| GENERATED by test/tools/gen-goldens.py -- do not edit by hand.++Reference std140/std430 layouts produced by glslangValidator ++spirv-cross. Regenerate with: python3 test/tools/gen-goldens.py+-}+module Spec.Layout.Golden+  ( Layout (..)+  , goldens+  ) where++data Layout = Layout+  { gStride :: Int+  -- ^ padded element size (array stride)+  , gLeaves :: [(Int, Int)]+  -- ^ absolute (offset, size) of each scalar leaf+  }+  deriving (Eq, Show)++-- | (struct name, std140 layout, std430 layout)+goldens :: [(String, Layout, Layout)]+goldens =+  [ ("CShorts16", Layout 16 [(0, 2), (2, 2), (4, 4)], Layout 8 [(0, 2), (2, 2), (4, 4)])+  , ("CTypes", Layout 32 [(0, 4), (4, 4), (8, 4), (16, 8)], Layout 24 [(0, 4), (4, 4), (8, 4), (16, 8)])+  , ("Doubles", Layout 32 [(0, 4), (8, 8), (16, 4)], Layout 24 [(0, 4), (8, 8), (16, 4)])+  , ("FloatArr", Layout 64 [(0, 4), (16, 4), (32, 4), (48, 4)], Layout 16 [(0, 4), (4, 4), (8, 4), (12, 4)])+  , ("HalfArr", Layout 64 [(0, 2), (16, 2), (32, 2), (48, 2)], Layout 8 [(0, 2), (2, 2), (4, 2), (6, 2)])+  , ("Halves", Layout 16 [(0, 2), (2, 2), (4, 4)], Layout 8 [(0, 2), (2, 2), (4, 4)])+  , ("MatVec", Layout 80 [(0, 64), (64, 16)], Layout 80 [(0, 64), (64, 16)])+  , ("MixArr", Layout 64 [(0, 4), (16, 4), (32, 4), (48, 4)], Layout 16 [(0, 4), (4, 4), (8, 4), (12, 4)])+  , ("Mixed", Layout 48 [(0, 4), (8, 8), (16, 4), (32, 4), (36, 4)], Layout 32 [(0, 4), (8, 8), (16, 4), (20, 4), (24, 4)])+  , ("NestPad", Layout 32 [(0, 4), (4, 4), (16, 4)], Layout 12 [(0, 4), (4, 4), (8, 4)])+  , ("Nested2", Layout 32 [(0, 4), (8, 8), (16, 4)], Layout 24 [(0, 4), (8, 8), (16, 4)])+  , ("Recordy", Layout 32 [(0, 4), (8, 8), (16, 4)], Layout 24 [(0, 4), (8, 8), (16, 4)])+  , ("Scalars", Layout 16 [(0, 4), (4, 4), (8, 4)], Layout 12 [(0, 4), (4, 4), (8, 4)])+  , ("ShortArr", Layout 64 [(0, 2), (16, 2), (32, 2), (48, 2)], Layout 8 [(0, 2), (2, 2), (4, 2), (6, 2)])+  , ("Shorts16", Layout 16 [(0, 2), (2, 2), (4, 4), (8, 2)], Layout 12 [(0, 2), (2, 2), (4, 4), (8, 2)])+  , ("Vec2Tail", Layout 16 [(0, 4), (4, 4), (8, 8)], Layout 16 [(0, 4), (4, 4), (8, 8)])+  , ("Vec3Pack", Layout 16 [(0, 12), (12, 4)], Layout 16 [(0, 12), (12, 4)])+  , ("Vec3Tail", Layout 32 [(0, 4), (16, 12)], Layout 32 [(0, 4), (16, 12)])+  , ("Vecs", Layout 48 [(0, 8), (16, 12), (32, 16)], Layout 48 [(0, 8), (16, 12), (32, 16)])+  , ("Wide64", Layout 32 [(0, 4), (8, 8), (16, 4), (24, 8)], Layout 32 [(0, 4), (8, 8), (16, 4), (24, 8)])+  ]

@@ -8,13 +8,13 @@  module Spec.Packed where -import Graphics.Gl.Block (Block, Packed(..))+import Graphics.Gl.Block (Block, Packed (..)) import Graphics.Gl.Block qualified as Block -import GHC.Generics (Generic)+import Data.Proxy (Proxy (..)) import Foreign (Storable) import Foreign qualified-import Data.Proxy (Proxy(..))+import GHC.Generics (Generic)  import Test.Tasty.HUnit @@ -25,16 +25,17 @@   , those :: (Float, Float) -- 4 + 4   }   deriving stock (Eq, Ord, Show, Generic)-  deriving anyclass Block-  deriving Storable via (Packed SomeStruct)+  deriving anyclass (Block)+  deriving (Storable) via (Packed SomeStruct)  someStruct :: SomeStruct-someStruct = SomeStruct-  { wat = True-  , this = 2 * pi-  , that = pi-  , those = (1/60, -1e6)-  }+someStruct =+  SomeStruct+    { wat = True+    , this = 2 * pi+    , that = pi+    , those = (1 / 60, -1e6)+    }  unit_packedSize :: (Block.PackedSize SomeStruct ~ 24) => Assertion unit_packedSize = Block.sizeOfPacked (Proxy :: Proxy SomeStruct) @?= 24

@@ -0,0 +1,167 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE TypeFamilies #-}++{-| Minimal local copies of geomancy-0.3.0.1's @Vec*@/@Mat4@ 'Block' instances,+so the vec/mat cross-check needs no geomancy dependency (geomancy can't be+wired in while gl-block is the local package -- an inverted Hackage+dependency). The layouts mirror geomancy exactly, including that the default+'Vec3' writes a 4th lane (1.0) whereas 'Vec3Packed' writes only three floats.+-}+module Spec.Types+  ( Vec2 (..)+  , Vec3 (..)+  , Vec3Packed (..)+  , Vec4 (..)+  , Mat4 (..)+  ) where++import Foreign+import Foreign.Ptr.Diff (peekDiffOff, pokeDiffOff)+import Graphics.Gl.Block (Block (..))++data Vec2 = Vec2 Float Float+  deriving stock (Eq, Show)++instance Storable Vec2 where+  sizeOf _ = 8+  alignment _ = 8+  peek p = Vec2 <$> peekElemOff (castPtr p) 0 <*> peekElemOff (castPtr p) 1+  poke p (Vec2 a b) = pokeElemOff (castPtr p) 0 a >> pokeElemOff (castPtr p) 1 b++instance Block Vec2 where+  type PackedSize Vec2 = 8+  alignment140 _ = 8+  sizeOf140 _ = 8+  alignment430 = alignment140+  sizeOf430 = sizeOf140+  isStruct _ = False+  read140 = peekDiffOff+  write140 = pokeDiffOff+  read430 = read140+  write430 = write140+  readPacked = read140+  writePacked = write140++-- | geomancy's default Vec3: a 16-byte host slot whose 'poke' writes a 4th lane.+data Vec3 = Vec3 Float Float Float+  deriving stock (Eq, Show)++instance Storable Vec3 where+  sizeOf _ = 16+  alignment _ = 4+  peek p =+    Vec3+      <$> peekElemOff (castPtr p) 0+      <*> peekElemOff (castPtr p) 1+      <*> peekElemOff (castPtr p) 2+  poke p (Vec3 a b c) = do+    let p' = castPtr p+    pokeElemOff p' 0 a+    pokeElemOff p' 1 b+    pokeElemOff p' 2 c+    pokeElemOff p' 3 (1.0 :: Float)++instance Block Vec3 where+  type PackedSize Vec3 = 12+  alignment140 _ = 16+  sizeOf140 _ = 16+  alignment430 = alignment140+  sizeOf430 = sizeOf140+  isStruct _ = False+  read140 = peekDiffOff+  write140 = pokeDiffOff+  read430 = read140+  write430 = write140+  readPacked = read140+  writePacked = write140++-- | geomancy's Vec3.Packed: a 12-byte host that writes exactly three floats.+newtype Vec3Packed = Vec3Packed Vec3+  deriving stock (Eq, Show)++instance Storable Vec3Packed where+  sizeOf _ = 12+  alignment _ = 4+  peek p =+    (\a b c -> Vec3Packed (Vec3 a b c))+      <$> peekElemOff (castPtr p) 0+      <*> peekElemOff (castPtr p) 1+      <*> peekElemOff (castPtr p) 2+  poke p (Vec3Packed (Vec3 a b c)) = do+    let p' = castPtr p+    pokeElemOff p' 0 a+    pokeElemOff p' 1 b+    pokeElemOff p' 2 c++instance Block Vec3Packed where+  type PackedSize Vec3Packed = 12+  alignment140 _ = 16+  sizeOf140 _ = 16+  alignment430 = alignment140+  sizeOf430 = sizeOf140+  isStruct _ = False+  read140 = peekDiffOff+  write140 = pokeDiffOff+  read430 = read140+  write430 = write140+  readPacked = read140+  writePacked = write140++data Vec4 = Vec4 Float Float Float Float+  deriving stock (Eq, Show)++instance Storable Vec4 where+  sizeOf _ = 16+  alignment _ = 16+  peek p =+    Vec4+      <$> peekElemOff (castPtr p) 0+      <*> peekElemOff (castPtr p) 1+      <*> peekElemOff (castPtr p) 2+      <*> peekElemOff (castPtr p) 3+  poke p (Vec4 a b c d) = do+    let p' = castPtr p+    pokeElemOff p' 0 a+    pokeElemOff p' 1 b+    pokeElemOff p' 2 c+    pokeElemOff p' 3 d++instance Block Vec4 where+  type PackedSize Vec4 = 16+  alignment140 _ = 16+  sizeOf140 _ = 16+  alignment430 = alignment140+  sizeOf430 = sizeOf140+  isStruct _ = False+  read140 = peekDiffOff+  write140 = pokeDiffOff+  read430 = read140+  write430 = write140+  readPacked = read140+  writePacked = write140++-- | mat4 as four column vec4s: 64 bytes, 16-byte aligned (column-major).+newtype Mat4 = Mat4 [Float]+  deriving stock (Eq, Show)++instance Storable Mat4 where+  sizeOf _ = 64+  alignment _ = 16+  peek p = Mat4 <$> traverse (peekElemOff (castPtr p)) [0 .. 15]+  poke p (Mat4 xs) =+    sequence_ [pokeElemOff (castPtr p) i x | (i, x) <- zip [0 ..] (take 16 (xs ++ repeat 0))]++instance Block Mat4 where+  type PackedSize Mat4 = 64+  alignment140 _ = 16+  sizeOf140 _ = 64+  alignment430 = alignment140+  sizeOf430 = sizeOf140+  isStruct _ = False+  read140 = peekDiffOff+  write140 = pokeDiffOff+  read430 = read140+  write430 = write140+  readPacked = read140+  writePacked = write140