diff --git a/ChangeLog.md b/ChangeLog.md
new file mode 100644
--- /dev/null
+++ b/ChangeLog.md
diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,229 @@
+# License
+
+Licensed under either of
+ * Apache License, Version 2.0 (http://www.apache.org/licenses/LICENSE-2.0)
+ * BSD 2-Clause license (https://opensource.org/licenses/BSD-2-Clause)
+at your option.
+
+## BSD 2-Clause License
+
+- Copyright 2014-2019 Edward Kmett
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions
+are met:
+
+1. Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+2. Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer in the
+ documentation and/or other materials provided with the distribution.
+
+THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+POSSIBILITY OF SUCH DAMAGE.
+
+## Apache License
+
+_Version 2.0, January 2004_
+_<>_
+
+### Terms and Conditions for use, reproduction, and distribution
+
+#### 1. Definitions
+
+“License” shall mean the terms and conditions for use, reproduction, and
+distribution as defined by Sections 1 through 9 of this document.
+
+“Licensor” shall mean the copyright owner or entity authorized by the copyright
+owner that is granting the License.
+
+“Legal Entity” shall mean the union of the acting entity and all other entities
+that control, are controlled by, or are under common control with that entity.
+For the purposes of this definition, “control” means **(i)** the power, direct or
+indirect, to cause the direction or management of such entity, whether by
+contract or otherwise, or **(ii)** ownership of fifty percent (50%) or more of the
+outstanding shares, or **(iii)** beneficial ownership of such entity.
+
+“You” (or “Your”) shall mean an individual or Legal Entity exercising
+permissions granted by this License.
+
+“Source” form shall mean the preferred form for making modifications, including
+but not limited to software source code, documentation source, and configuration
+files.
+
+“Object” form shall mean any form resulting from mechanical transformation or
+translation of a Source form, including but not limited to compiled object code,
+generated documentation, and conversions to other media types.
+
+“Work” shall mean the work of authorship, whether in Source or Object form, made
+available under the License, as indicated by a copyright notice that is included
+in or attached to the work (an example is provided in the Appendix below).
+
+“Derivative Works” shall mean any work, whether in Source or Object form, that
+is based on (or derived from) the Work and for which the editorial revisions,
+annotations, elaborations, or other modifications represent, as a whole, an
+original work of authorship. For the purposes of this License, Derivative Works
+shall not include works that remain separable from, or merely link (or bind by
+name) to the interfaces of, the Work and Derivative Works thereof.
+
+“Contribution” shall mean any work of authorship, including the original version
+of the Work and any modifications or additions to that Work or Derivative Works
+thereof, that is intentionally submitted to Licensor for inclusion in the Work
+by the copyright owner or by an individual or Legal Entity authorized to submit
+on behalf of the copyright owner. For the purposes of this definition,
+“submitted” means any form of electronic, verbal, or written communication sent
+to the Licensor or its representatives, including but not limited to
+communication on electronic mailing lists, source code control systems, and
+issue tracking systems that are managed by, or on behalf of, the Licensor for
+the purpose of discussing and improving the Work, but excluding communication
+that is conspicuously marked or otherwise designated in writing by the copyright
+owner as “Not a Contribution.”
+
+“Contributor” shall mean Licensor and any individual or Legal Entity on behalf
+of whom a Contribution has been received by Licensor and subsequently
+incorporated within the Work.
+
+#### 2. Grant of Copyright License
+
+Subject to the terms and conditions of this License, each Contributor hereby
+grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free,
+irrevocable copyright license to reproduce, prepare Derivative Works of,
+publicly display, publicly perform, sublicense, and distribute the Work and such
+Derivative Works in Source or Object form.
+
+#### 3. Grant of Patent License
+
+Subject to the terms and conditions of this License, each Contributor hereby
+grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free,
+irrevocable (except as stated in this section) patent license to make, have
+made, use, offer to sell, sell, import, and otherwise transfer the Work, where
+such license applies only to those patent claims licensable by such Contributor
+that are necessarily infringed by their Contribution(s) alone or by combination
+of their Contribution(s) with the Work to which such Contribution(s) was
+submitted. If You institute patent litigation against any entity (including a
+cross-claim or counterclaim in a lawsuit) alleging that the Work or a
+Contribution incorporated within the Work constitutes direct or contributory
+patent infringement, then any patent licenses granted to You under this License
+for that Work shall terminate as of the date such litigation is filed.
+
+#### 4. Redistribution
+
+You may reproduce and distribute copies of the Work or Derivative Works thereof
+in any medium, with or without modifications, and in Source or Object form,
+provided that You meet the following conditions:
+
+* **(a)** You must give any other recipients of the Work or Derivative Works a copy of
+this License; and
+* **(b)** You must cause any modified files to carry prominent notices stating that You
+changed the files; and
+* **(c)** You must retain, in the Source form of any Derivative Works that You distribute,
+all copyright, patent, trademark, and attribution notices from the Source form
+of the Work, excluding those notices that do not pertain to any part of the
+Derivative Works; and
+* **(d)** If the Work includes a “NOTICE” text file as part of its distribution, then any
+Derivative Works that You distribute must include a readable copy of the
+attribution notices contained within such NOTICE file, excluding those notices
+that do not pertain to any part of the Derivative Works, in at least one of the
+following places: within a NOTICE text file distributed as part of the
+Derivative Works; within the Source form or documentation, if provided along
+with the Derivative Works; or, within a display generated by the Derivative
+Works, if and wherever such third-party notices normally appear. The contents of
+the NOTICE file are for informational purposes only and do not modify the
+License. You may add Your own attribution notices within Derivative Works that
+You distribute, alongside or as an addendum to the NOTICE text from the Work,
+provided that such additional attribution notices cannot be construed as
+modifying the License.
+
+You may add Your own copyright statement to Your modifications and may provide
+additional or different license terms and conditions for use, reproduction, or
+distribution of Your modifications, or for any such Derivative Works as a whole,
+provided Your use, reproduction, and distribution of the Work otherwise complies
+with the conditions stated in this License.
+
+#### 5. Submission of Contributions
+
+Unless You explicitly state otherwise, any Contribution intentionally submitted
+for inclusion in the Work by You to the Licensor shall be under the terms and
+conditions of this License, without any additional terms or conditions.
+Notwithstanding the above, nothing herein shall supersede or modify the terms of
+any separate license agreement you may have executed with Licensor regarding
+such Contributions.
+
+#### 6. Trademarks
+
+This License does not grant permission to use the trade names, trademarks,
+service marks, or product names of the Licensor, except as required for
+reasonable and customary use in describing the origin of the Work and
+reproducing the content of the NOTICE file.
+
+#### 7. Disclaimer of Warranty
+
+Unless required by applicable law or agreed to in writing, Licensor provides the
+Work (and each Contributor provides its Contributions) on an “AS IS” BASIS,
+WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied,
+including, without limitation, any warranties or conditions of TITLE,
+NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A PARTICULAR PURPOSE. You are
+solely responsible for determining the appropriateness of using or
+redistributing the Work and assume any risks associated with Your exercise of
+permissions under this License.
+
+#### 8. Limitation of Liability
+
+In no event and under no legal theory, whether in tort (including negligence),
+contract, or otherwise, unless required by applicable law (such as deliberate
+and grossly negligent acts) or agreed to in writing, shall any Contributor be
+liable to You for damages, including any direct, indirect, special, incidental,
+or consequential damages of any character arising as a result of this License or
+out of the use or inability to use the Work (including but not limited to
+damages for loss of goodwill, work stoppage, computer failure or malfunction, or
+any and all other commercial damages or losses), even if such Contributor has
+been advised of the possibility of such damages.
+
+#### 9. Accepting Warranty or Additional Liability
+
+While redistributing the Work or Derivative Works thereof, You may choose to
+offer, and charge a fee for, acceptance of support, warranty, indemnity, or
+other liability obligations and/or rights consistent with this License. However,
+in accepting such obligations, You may act only on Your own behalf and on Your
+sole responsibility, not on behalf of any other Contributor, and only if You
+agree to indemnify, defend, and hold each Contributor harmless for any liability
+incurred by, or claims asserted against, such Contributor by reason of your
+accepting any such warranty or additional liability.
+
+_END OF TERMS AND CONDITIONS_
+
+### APPENDIX: How to apply the Apache License to your work
+
+To apply the Apache License to your work, attach the following boilerplate
+notice, with the fields enclosed by brackets `[]` replaced with your own
+identifying information. (Don't include the brackets!) The text should be
+enclosed in the appropriate comment syntax for the file format. We also
+recommend that a file or class name and description of purpose be included on
+the same “printed page” as the copyright notice for easier identification within
+third-party archives.
+
+ Copyright [yyyy] [name of copyright owner]
+
+ Licensed under the Apache License, Version 2.0 (the "License");
+ you may not use this file except in compliance with the License.
+ You may obtain a copy of the License at
+
+ http://www.apache.org/licenses/LICENSE-2.0
+
+ Unless required by applicable law or agreed to in writing, software
+ distributed under the License is distributed on an "AS IS" BASIS,
+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+ See the License for the specific language governing permissions and
+ limitations under the License.
diff --git a/README.md b/README.md
new file mode 100644
--- /dev/null
+++ b/README.md
@@ -0,0 +1,89 @@
+## gl-block
+
+### Using
+
+Primitive types should have the `Block` instance.
+With that in place, you can build structures and get Storable instances derived generically, according to intented usage.
+
+```haskell
+import GHC.Generics (Generic)
+import Graphics.Gl.Block (Block, Packed(..), Std140(..), Std430(..))
+
+-- | Attribute streams can be packed tightly together
+data VertexAttrs = VertexAttrs
+ { color :: Vec4
+ , texCoords :: Vec2
+ }
+ deriving stock (Eq, Ord, Show, Generic) -- The regular stuff and Generic
+ deriving anyclass Block -- The layout class, with Generic defaults
+ deriving Storable via (Packed VertexAttrs) -- Free goodies!
+
+-- | Uniform data require jumping through padding and alignment flaming hoop.
+-- You can use derive-storable-plugin or hs2c instead, but there are gotchas.
+data SceneUniform = SceneUniform
+ { projection :: Mat4
+ , viewPosition :: Vec3 -- Here comes the jazz
+ , viewDirection :: Vec3
+ }
+ deriving stock (Eq, Ord, Show, Generic)
+ deriving anyclass Block
+ deriving Storable via (Std140 VertexAttrs) -- With comfy padding
+
+-- | Shader buffer objects are less vacuous, but the rules are specific to the domain.
+data Material = Material
+ { baseColor :: Vec4
+ , metallicRoughness :: Vec2
+ , emission :: Vec4
+ }
+ deriving stock (Eq, Ord, Show, Generic)
+ deriving anyclass Block
+ deriving Storable via (Std430 VertexAttrs) -- Less alignment, less calculations
+```
+
+* [Shader Buffer Memory Layout Info](https://gist.github.com/teoxoy/936891c16c2a3d1c3c5e7204ac6cd76c)
+
+
+
+### Benchmarks
+
+The benchmark consists of filling a Storable vector.
+
+* Packed layout is on par with manual instances.
+* Std140 is slower, but not catastrophically so.
+* Std430 seems to regain some performance due to being a tad simpler.
+
+> There's only one "manual" case standing for all the layouts since it would only be different in pointer offsets.
+> And no way in hell I'm going to calculate them by hand!
+
+```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
+ 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
+ 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
+```
+
+> Caveat: nested structures have degraded performance.
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/bench/Bench.hs b/bench/Bench.hs
new file mode 100644
--- /dev/null
+++ b/bench/Bench.hs
@@ -0,0 +1,42 @@
+{-# LANGUAGE ImportQualifiedPost #-}
+
+import Test.Tasty.Bench (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
+ ]
+ ]
+ ]
diff --git a/bench/Bench/Struct.hs b/bench/Bench/Struct.hs
new file mode 100644
--- /dev/null
+++ b/bench/Bench/Struct.hs
@@ -0,0 +1,105 @@
+{-# LANGUAGE Strict #-}
+
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE ImportQualifiedPost #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module Bench.Struct where
+
+import Foreign
+import GHC.Generics (Generic)
+
+import Graphics.Gl.Block (Block, Packed(..), Std140(..), Std430(..))
+
+data StructManual = StructManual
+ { smWat :: Bool -- 4
+ , smThis :: Double -- 8
+ , smThat :: Float -- 4
+ , smThose :: (Float, Float) -- 4 + 4
+ }
+ deriving stock (Eq, Ord, Show, Generic)
+
+structManual :: StructManual
+structManual = StructManual
+ { smWat = True
+ , smThis = 2 * pi
+ , smThat = pi
+ , smThose = (1/60, -1e6)
+ }
+
+instance Storable StructManual where
+ alignment ~_ = 8
+ sizeOf ~_ = 24
+ peek ptr =
+ StructManual
+ <$> peekByteOff ptr 0
+ <*> peekByteOff ptr 4
+ <*> peekByteOff ptr 12
+ <*> (
+ (,)
+ <$> peekByteOff ptr 16
+ <*> peekByteOff ptr 20
+ )
+ poke ptr StructManual{..} = do
+ pokeByteOff ptr 0 smWat
+ pokeByteOff ptr 4 smThis
+ pokeByteOff ptr 12 smThat
+ pokeByteOff ptr 16 (fst smThose)
+ pokeByteOff ptr 20 (snd smThose)
+
+data StructPacked = StructPacked
+ { spWat :: Bool -- 4
+ , spThis :: Double -- 8
+ , spThat :: Float -- 4
+ , spThose :: (Float, Float) -- 4 + 4
+ }
+ deriving stock (Eq, Ord, Show, Generic)
+ deriving anyclass Block
+ deriving Storable via (Packed StructPacked)
+
+structPacked :: StructPacked
+structPacked = StructPacked
+ { spWat = True
+ , spThis = 2 * pi
+ , spThat = pi
+ , spThose = (1/60, -1e6)
+ }
+
+data Struct140 = Struct140
+ { std140Wat :: Bool -- 4
+ , std140This :: Double -- 8
+ , std140That :: Float -- 4
+ , std140Those :: (Float, Float) -- 4 + 4
+ }
+ deriving stock (Eq, Ord, Show, Generic)
+ deriving anyclass Block
+ deriving Storable via (Std140 Struct140)
+
+struct140 :: Struct140
+struct140 = Struct140
+ { std140Wat = True
+ , std140This = 2 * pi
+ , std140That = pi
+ , std140Those = (1/60, -1e6)
+ }
+
+data Struct430 = Struct430
+ { std430Wat :: Bool -- 4
+ , std430This :: Double -- 8
+ , std430That :: Float -- 4
+ , std430Those :: (Float, Float) -- 4 + 4
+ }
+ deriving stock (Eq, Ord, Show, Generic)
+ deriving anyclass Block
+ deriving Storable via (Std430 Struct430)
+
+struct430 :: Struct430
+struct430 = Struct430
+ { std430Wat = True
+ , std430This = 2 * pi
+ , std430That = pi
+ , std430Those = (1/60, -1e6)
+ }
diff --git a/gl-block.cabal b/gl-block.cabal
new file mode 100644
--- /dev/null
+++ b/gl-block.cabal
@@ -0,0 +1,77 @@
+cabal-version: 2.2
+
+-- This file has been generated from package.yaml by hpack version 0.35.2.
+--
+-- see: https://github.com/sol/hpack
+
+name: gl-block
+version: 1.0
+synopsis: OpenGL standard memory layouts
+category: Graphics
+author: IC Rainbow
+maintainer: ic.rbow@gmail.com
+copyright: 2023 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
+ ChangeLog.md
+
+source-repository head
+ type: git
+ location: https://gitlab.com/dpwiz/gl-block
+
+library
+ exposed-modules:
+ Graphics.Gl.Block
+ other-modules:
+ Paths_gl_block
+ autogen-modules:
+ Paths_gl_block
+ hs-source-dirs:
+ src
+ ghc-options: -Wall
+ build-depends:
+ base >=4.7 && <5
+ , ptrdiff
+ default-language: Haskell2010
+
+test-suite gl-block-test
+ type: exitcode-stdio-1.0
+ main-is: Spec.hs
+ other-modules:
+ Spec.Packed
+ Paths_gl_block
+ autogen-modules:
+ Paths_gl_block
+ hs-source-dirs:
+ test
+ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -with-rtsopts=-qn1 -with-rtsopts=-A128m
+ build-tool-depends:
+ tasty-discover:tasty-discover
+ build-depends:
+ base >=4.7 && <5
+ , gl-block
+ , tasty
+ , tasty-hunit
+ default-language: Haskell2010
+
+benchmark gl-block-bench
+ type: exitcode-stdio-1.0
+ main-is: Bench.hs
+ other-modules:
+ Bench.Struct
+ Paths_gl_block
+ autogen-modules:
+ Paths_gl_block
+ hs-source-dirs:
+ bench
+ ghc-options: -Wall -O2 -threaded -rtsopts -with-rtsopts=-N1 -fproc-alignment=64 -with-rtsopts=-A128m
+ build-depends:
+ base >=4.7 && <5
+ , gl-block
+ , tasty
+ , tasty-bench
+ , vector
+ default-language: Haskell2010
diff --git a/src/Graphics/Gl/Block.hs b/src/Graphics/Gl/Block.hs
new file mode 100644
--- /dev/null
+++ b/src/Graphics/Gl/Block.hs
@@ -0,0 +1,429 @@
+{-# 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 IC Rainbow
+ (c) 2014-2019 Edward Kmett
+License : BSD-2-Clause OR Apache-2.0
+Maintainer: IC Rainbow
+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 (Int32)
+import Data.Proxy (Proxy(..))
+import Data.Word (Word32)
+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)
+
+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
+ 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
+ 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))
+
+ gsizeOf140 _ =
+ roundUp
+ (gsizeOf140 (Proxy :: Proxy f))
+ (galignment140 (Proxy :: Proxy g))
+ + gsizeOf140 (Proxy :: Proxy g)
+
+ gsizeOf430 _ =
+ roundUp
+ (gsizeOf430 (Proxy :: Proxy f))
+ (galignment430 (Proxy :: Proxy g))
+ + gsizeOf430 (Proxy :: Proxy g)
+
+ gread140 p o = (:*:)
+ <$> gread140 p o
+ <*> gread140 p (o + roundUp (gsizeOf140 (Proxy :: Proxy f)) (galignment140 (Proxy :: Proxy g)))
+
+ gread430 p o = (:*:)
+ <$> gread430 p o
+ <*> gread430 p (o + roundUp (gsizeOf430 (Proxy :: Proxy f)) (galignment430 (Proxy :: Proxy g)))
+
+ 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
+
+ gwrite430 p o (a :*: b) = do
+ gwrite430 p o a
+ gwrite430 p (o + roundUp (gsizeOf430 (Proxy :: Proxy f)) (galignment430 (Proxy :: Proxy g))) 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)
+ 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 _ = lcm 16 $ galignment140 (Proxy :: Proxy f) -- std140 rule 9
+ 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
+ gsizeOfPacked _ = gsizeOfPacked (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)
+ 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)
+ gread140 p o = K1 <$> read140 p (Diff o)
+ gread430 p o = K1 <$> read430 p (Diff o)
+ 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
+ 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 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 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 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 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 #-}
+
+-- -- | 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))
+
+-- | @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)
diff --git a/test/Spec.hs b/test/Spec.hs
new file mode 100644
--- /dev/null
+++ b/test/Spec.hs
@@ -0,0 +1,2 @@
+{-# OPTIONS_GHC -F -pgmF tasty-discover #-}
+{-# OPTIONS_GHC -Wno-prepositive-qualified-module #-}
diff --git a/test/Spec/Packed.hs b/test/Spec/Packed.hs
new file mode 100644
--- /dev/null
+++ b/test/Spec/Packed.hs
@@ -0,0 +1,45 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE ImportQualifiedPost #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Spec.Packed where
+
+import Graphics.Gl.Block (Block, Packed(..))
+import Graphics.Gl.Block qualified as Block
+
+import GHC.Generics (Generic)
+import Foreign (Storable)
+import Foreign qualified
+import Data.Proxy (Proxy(..))
+
+import Test.Tasty.HUnit
+
+data SomeStruct = SomeStruct
+ { wat :: Bool -- 4
+ , this :: Double -- 8
+ , that :: Float -- 4
+ , those :: (Float, Float) -- 4 + 4
+ }
+ deriving stock (Eq, Ord, Show, Generic)
+ deriving anyclass Block
+ deriving Storable via (Packed SomeStruct)
+
+someStruct :: SomeStruct
+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
+
+unit_peekPoked :: Assertion
+unit_peekPoked = do
+ tripped <- Foreign.with someStruct Foreign.peek
+ tripped @?= someStruct