gl-block (empty) → 1.0

raw patch · 10 files changed

+1020/−0 lines, 10 filesdep +basedep +gl-blockdep +ptrdiffsetup-changed

Dependencies added: base, gl-block, ptrdiff, tasty, tasty-bench, tasty-hunit, vector

Files

ChangeLog.md +0/−0
LICENSE +229/−0
README.md +89/−0
Setup.hs +2/−0
bench/Bench.hs +42/−0
bench/Bench/Struct.hs +105/−0
gl-block.cabal +77/−0
src/Graphics/Gl/Block.hs +429/−0
test/Spec.hs +2/−0
test/Spec/Packed.hs +45/−0

+ ChangeLog.md view

+ LICENSE view

@@ -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_  +_&lt;<http://www.apache.org/licenses/>&gt;_++### 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.

+ README.md view

@@ -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.

+ Setup.hs view

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

+ bench/Bench.hs view

@@ -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+          ]+      ]+  ]

+ bench/Bench/Struct.hs view

@@ -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)+  }

+ gl-block.cabal view

@@ -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

+ src/Graphics/Gl/Block.hs view

@@ -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 <aenor.realm@gmail.com>+Stability: experimental+Portability: non-portable++OpenGL std140 and std430 support+-}+module Graphics.Gl.Block+  ( Block(..)+  , GBlock(..)+  , Packed(..)+  , Std140(..)+  , Std430(..)+  , roundUp+  ) where++import Control.Monad.IO.Class (MonadIO(..))+import Data.Data (Data, Typeable)+import Data.Int (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)

+ test/Spec.hs view

@@ -0,0 +1,2 @@+{-# OPTIONS_GHC -F -pgmF tasty-discover #-}+{-# OPTIONS_GHC -Wno-prepositive-qualified-module #-}

+ test/Spec/Packed.hs view

@@ -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