module Resource.Gltf.Load
  ( loadMeshPrimitives

  , loadGlb
  , loadGlbChunks

  , loadGltf

  , loadUri
  ) where

import RIO

import Codec.GLB qualified as GLB
import Codec.GlTF qualified as GlTF
import Codec.GlTF.Accessor qualified as Accessor
import Codec.GlTF.Buffer qualified as Buffer
import Codec.GlTF.BufferView qualified as BufferView
import Codec.GlTF.Material qualified as Material
import Codec.GlTF.Mesh qualified as Mesh
import Codec.GlTF.Root qualified as Root
import Codec.GlTF.URI qualified as URI
import Data.ByteString.Unsafe qualified as ByteString
import Data.Vector qualified as Vector
import Foreign qualified
import Geomancy (Vec2, Vec4, vec3, withVec4)
import Geomancy.Vec3 qualified as Vec3
import RIO.ByteString qualified as ByteString
import RIO.FilePath (takeDirectory, takeExtensions, (</>))
import RIO.HashMap qualified as HashMap
import RIO.List qualified as List

import Resource.Compressed.Zstd qualified as Zstd
import Resource.Gltf.Model (MeshPrimitive, Stuff(..), VertexAttrs(..))

loadGlb :: FilePath -> IO (Either String (ByteString, Root.GlTF))
loadGlb :: String -> IO (Either String (ByteString, GlTF))
loadGlb String
sceneFile =
  String -> IO (Either String (Vector Chunk))
loadGlbChunks String
sceneFile IO (Either String (Vector Chunk))
-> (Either String (Vector Chunk)
    -> IO (Either String (ByteString, GlTF)))
-> IO (Either String (ByteString, GlTF))
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Right Vector Chunk
chunks ->
      case Vector Chunk -> [Chunk]
forall a. Vector a -> [a]
Vector.toList Vector Chunk
chunks of
        [] ->
          Either String (ByteString, GlTF)
-> IO (Either String (ByteString, GlTF))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String (ByteString, GlTF)
 -> IO (Either String (ByteString, GlTF)))
-> (String -> Either String (ByteString, GlTF))
-> String
-> IO (Either String (ByteString, GlTF))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either String (ByteString, GlTF)
forall a b. a -> Either a b
Left (String -> IO (Either String (ByteString, GlTF)))
-> String -> IO (Either String (ByteString, GlTF))
forall a b. (a -> b) -> a -> b
$ String
"No chunks in GLB file " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
forall a. Show a => a -> String
show String
sceneFile
        [Chunk
_root] ->
          Either String (ByteString, GlTF)
-> IO (Either String (ByteString, GlTF))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String (ByteString, GlTF)
 -> IO (Either String (ByteString, GlTF)))
-> (String -> Either String (ByteString, GlTF))
-> String
-> IO (Either String (ByteString, GlTF))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either String (ByteString, GlTF)
forall a b. a -> Either a b
Left (String -> IO (Either String (ByteString, GlTF)))
-> String -> IO (Either String (ByteString, GlTF))
forall a b. (a -> b) -> a -> b
$ String
"No data chunk in GLB file " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
forall a. Show a => a -> String
show String
sceneFile
        Chunk
gltf : Chunk
buffer : [Chunk]
_rest ->
          Either String (ByteString, GlTF)
-> IO (Either String (ByteString, GlTF))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String (ByteString, GlTF)
 -> IO (Either String (ByteString, GlTF)))
-> Either String (ByteString, GlTF)
-> IO (Either String (ByteString, GlTF))
forall a b. (a -> b) -> a -> b
$
            (GlTF -> (ByteString, GlTF))
-> Either String GlTF -> Either String (ByteString, GlTF)
forall a b. (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Chunk -> ByteString
GLB.chunkData Chunk
buffer,) (Either String GlTF -> Either String (ByteString, GlTF))
-> Either String GlTF -> Either String (ByteString, GlTF)
forall a b. (a -> b) -> a -> b
$
              Chunk -> Either String GlTF
GlTF.fromChunk Chunk
gltf
    Left String
err ->
      Either String (ByteString, GlTF)
-> IO (Either String (ByteString, GlTF))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String (ByteString, GlTF)
 -> IO (Either String (ByteString, GlTF)))
-> Either String (ByteString, GlTF)
-> IO (Either String (ByteString, GlTF))
forall a b. (a -> b) -> a -> b
$ String -> Either String (ByteString, GlTF)
forall a b. a -> Either a b
Left String
err

loadGlbChunks :: FilePath -> IO (Either String (Vector GLB.Chunk))
loadGlbChunks :: String -> IO (Either String (Vector Chunk))
loadGlbChunks String
sceneFile =
  (ByteString -> IO (Either (ByteOffset, String) GLB))
-> (String -> IO (Either (ByteOffset, String) GLB))
-> String
-> IO (Either (ByteOffset, String) GLB)
forall (m :: * -> *) b.
MonadIO m =>
(ByteString -> m b) -> (String -> m b) -> String -> m b
Zstd.fromFileWith (Either (ByteOffset, String) GLB
-> IO (Either (ByteOffset, String) GLB)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (ByteOffset, String) GLB
 -> IO (Either (ByteOffset, String) GLB))
-> (ByteString -> Either (ByteOffset, String) GLB)
-> ByteString
-> IO (Either (ByteOffset, String) GLB)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either (ByteOffset, String) GLB
GLB.fromByteString) String -> IO (Either (ByteOffset, String) GLB)
GLB.fromFile String
sceneFile IO (Either (ByteOffset, String) GLB)
-> (Either (ByteOffset, String) GLB
    -> IO (Either String (Vector Chunk)))
-> IO (Either String (Vector Chunk))
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Right GLB
glb ->
      Either String (Vector Chunk) -> IO (Either String (Vector Chunk))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String (Vector Chunk) -> IO (Either String (Vector Chunk)))
-> Either String (Vector Chunk)
-> IO (Either String (Vector Chunk))
forall a b. (a -> b) -> a -> b
$ Vector Chunk -> Either String (Vector Chunk)
forall a b. b -> Either a b
Right (GLB -> Vector Chunk
GLB.chunks GLB
glb)
    Left (ByteOffset
_offset, String
err) ->
      Either String (Vector Chunk) -> IO (Either String (Vector Chunk))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String (Vector Chunk) -> IO (Either String (Vector Chunk)))
-> Either String (Vector Chunk)
-> IO (Either String (Vector Chunk))
forall a b. (a -> b) -> a -> b
$ String -> Either String (Vector Chunk)
forall a b. a -> Either a b
Left String
err

loadGltf :: FilePath -> IO (Either String Root.GlTF)
loadGltf :: String -> IO (Either String GlTF)
loadGltf =
  (ByteString -> IO (Either String GlTF))
-> (String -> IO (Either String GlTF))
-> String
-> IO (Either String GlTF)
forall (m :: * -> *) b.
MonadIO m =>
(ByteString -> m b) -> (String -> m b) -> String -> m b
Zstd.fromFileWith (Either String GlTF -> IO (Either String GlTF)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String GlTF -> IO (Either String GlTF))
-> (ByteString -> Either String GlTF)
-> ByteString
-> IO (Either String GlTF)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String GlTF
GlTF.fromByteString) String -> IO (Either String GlTF)
GlTF.fromFile

loadUri :: FilePath -> FilePath -> IO (Either a ByteString)
loadUri :: forall a. String -> String -> IO (Either a ByteString)
loadUri String
sceneFile String
uri =
  (ByteString -> Either a ByteString)
-> IO ByteString -> IO (Either a ByteString)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Either a ByteString
forall a b. b -> Either a b
Right (IO ByteString -> IO (Either a ByteString))
-> (String -> IO ByteString) -> String -> IO (Either a ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> IO ByteString)
-> (String -> IO ByteString) -> String -> IO ByteString
forall (m :: * -> *) b.
MonadIO m =>
(ByteString -> m b) -> (String -> m b) -> String -> m b
Zstd.fromFileWith ByteString -> IO ByteString
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String -> IO ByteString
forall (m :: * -> *). MonadIO m => String -> m ByteString
ByteString.readFile (String -> IO (Either a ByteString))
-> String -> IO (Either a ByteString)
forall a b. (a -> b) -> a -> b
$
    String -> String
takeDirectory String
sceneFile String -> String -> String
</> String
uri

-- XXX: OTOH, it may be better to unfold scene first 🤔
loadMeshPrimitives
  :: ( MonadReader env m
     , HasLogFunc env
     , MonadThrow m
     , MonadUnliftIO m
     )
  => Bool
  -> Bool
  -> FilePath
  -> m
    ( Root.GlTF
    , Vector (Vector MeshPrimitive)
    )
loadMeshPrimitives :: forall env (m :: * -> *).
(MonadReader env m, HasLogFunc env, MonadThrow m,
 MonadUnliftIO m) =>
Bool -> Bool -> String -> m (GlTF, Vector (Vector MeshPrimitive))
loadMeshPrimitives Bool
reverseIndices Bool
addBacksides String
fp = do
  Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder -> m ()) -> Utf8Builder -> m ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Loading scene from " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> String -> Utf8Builder
forall a. IsString a => String -> a
fromString String
fp

  (Maybe ByteString
glbData, GlTF
root) <- IO (Maybe ByteString, GlTF) -> m (Maybe ByteString, GlTF)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe ByteString, GlTF) -> m (Maybe ByteString, GlTF))
-> IO (Maybe ByteString, GlTF) -> m (Maybe ByteString, GlTF)
forall a b. (a -> b) -> a -> b
$
    if String -> String
takeExtensions String
fp String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
".glb", String
".glb.zst"] then
      String -> IO (Either String (ByteString, GlTF))
loadGlb String
fp IO (Either String (ByteString, GlTF))
-> (Either String (ByteString, GlTF)
    -> IO (Maybe ByteString, GlTF))
-> IO (Maybe ByteString, GlTF)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left String
err ->
          String -> IO (Maybe ByteString, GlTF)
forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString (String -> IO (Maybe ByteString, GlTF))
-> String -> IO (Maybe ByteString, GlTF)
forall a b. (a -> b) -> a -> b
$ String
"GLB load error: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
err
        Right (ByteString
buffer, GlTF
root) ->
          (Maybe ByteString, GlTF) -> IO (Maybe ByteString, GlTF)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
buffer, GlTF
root)
    else
      String -> IO (Either String GlTF)
loadGltf String
fp IO (Either String GlTF)
-> (Either String GlTF -> IO (Maybe ByteString, GlTF))
-> IO (Maybe ByteString, GlTF)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left String
err ->
          String -> IO (Maybe ByteString, GlTF)
forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString (String -> IO (Maybe ByteString, GlTF))
-> String -> IO (Maybe ByteString, GlTF)
forall a b. (a -> b) -> a -> b
$ String
"glTF load error: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
err
        Right GlTF
root ->
          (Maybe ByteString, GlTF) -> IO (Maybe ByteString, GlTF)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ByteString
forall a. Maybe a
Nothing, GlTF
root)

  Vector ByteString
buffers <- case GlTF -> Maybe (Vector Buffer)
Root.buffers GlTF
root of
    Maybe (Vector Buffer)
Nothing ->
      Vector ByteString -> m (Vector ByteString)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Vector ByteString
forall a. Monoid a => a
mempty
    Just Vector Buffer
buffers ->
      Vector Buffer -> (Buffer -> m ByteString) -> m (Vector ByteString)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for Vector Buffer
buffers \case
        Buffer.Buffer{$sel:uri:Buffer :: Buffer -> Maybe URI
uri=Maybe URI
Nothing} ->
          case Maybe ByteString
glbData of
            Maybe ByteString
Nothing ->
              String -> m ByteString
forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString (String -> m ByteString) -> String -> m ByteString
forall a b. (a -> b) -> a -> b
$ String
"Empty buffer URI in " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
forall a. Show a => a -> String
show String
fp -- XXX: not loading GLB, are we?
            Just ByteString
bs ->
              ByteString -> m ByteString
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
bs
        Buffer.Buffer{$sel:uri:Buffer :: Buffer -> Maybe URI
uri=Just URI
path} ->
          IO (Either String ByteString) -> m (Either String ByteString)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (HasCallStack =>
(String -> IO (Either String ByteString))
-> URI -> IO (Either String ByteString)
(String -> IO (Either String ByteString))
-> URI -> IO (Either String ByteString)
URI.loadURI (String -> String -> IO (Either String ByteString)
forall a. String -> String -> IO (Either a ByteString)
loadUri String
fp) URI
path) m (Either String ByteString)
-> (Either String ByteString -> m ByteString) -> m ByteString
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Left String
err ->
              String -> m ByteString
forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString (String -> m ByteString) -> String -> m ByteString
forall a b. (a -> b) -> a -> b
$ String
"Buffer load failed for " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> URI -> String
forall a. Show a => a -> String
show URI
path String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
err
            Right ByteString
bs ->
              ByteString -> m ByteString
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
bs
  let
    getBuffer :: BufferIx -> m ByteString
getBuffer BufferIx
bix =
      case Vector ByteString
buffers Vector ByteString -> Int -> Maybe ByteString
forall a. Vector a -> Int -> Maybe a
Vector.!? BufferIx -> Int
Buffer.unBufferIx BufferIx
bix of
        Maybe ByteString
Nothing ->
          String -> m ByteString
forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString (String -> m ByteString) -> String -> m ByteString
forall a b. (a -> b) -> a -> b
$ BufferIx -> String
forall a. Show a => a -> String
show BufferIx
bix String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" not present in " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
forall a. Show a => a -> String
show String
fp
        Just ByteString
buffer ->
          ByteString -> m ByteString
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
buffer

  AccessorIx -> m Accessor
getAccessor <- case GlTF -> Maybe (Vector Accessor)
Root.accessors GlTF
root of
    Maybe (Vector Accessor)
Nothing ->
      String -> m (AccessorIx -> m Accessor)
forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString (String -> m (AccessorIx -> m Accessor))
-> String -> m (AccessorIx -> m Accessor)
forall a b. (a -> b) -> a -> b
$ String
"No accessors in " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
fp
    Just Vector Accessor
accessors ->
      (AccessorIx -> m Accessor) -> m (AccessorIx -> m Accessor)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure \AccessorIx
aix ->
        case Vector Accessor
accessors Vector Accessor -> Int -> Maybe Accessor
forall a. Vector a -> Int -> Maybe a
Vector.!? AccessorIx -> Int
Accessor.unAccessorIx AccessorIx
aix of
          Maybe Accessor
Nothing ->
            String -> m Accessor
forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString (String -> m Accessor) -> String -> m Accessor
forall a b. (a -> b) -> a -> b
$ AccessorIx -> String
forall a. Show a => a -> String
show AccessorIx
aix String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" not present in " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
forall a. Show a => a -> String
show String
fp
          Just Accessor
accessor ->
            Accessor -> m Accessor
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Accessor
accessor

  BufferViewIx -> m BufferView
getBufferView <- case GlTF -> Maybe (Vector BufferView)
Root.bufferViews GlTF
root of
    Maybe (Vector BufferView)
Nothing ->
      String -> m (BufferViewIx -> m BufferView)
forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString (String -> m (BufferViewIx -> m BufferView))
-> String -> m (BufferViewIx -> m BufferView)
forall a b. (a -> b) -> a -> b
$ String
"No buffer views in " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
fp
    Just Vector BufferView
bufferViews ->
      (BufferViewIx -> m BufferView) -> m (BufferViewIx -> m BufferView)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure \BufferViewIx
bvix ->
        case Vector BufferView
bufferViews Vector BufferView -> Int -> Maybe BufferView
forall a. Vector a -> Int -> Maybe a
Vector.!? BufferViewIx -> Int
BufferView.unBufferViewIx BufferViewIx
bvix of
          Maybe BufferView
Nothing ->
            String -> m BufferView
forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString (String -> m BufferView) -> String -> m BufferView
forall a b. (a -> b) -> a -> b
$ BufferViewIx -> String
forall a. Show a => a -> String
show BufferViewIx
bvix String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" not present in " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
forall a. Show a => a -> String
show String
fp
          Just BufferView
bufferView ->
            BufferView -> m BufferView
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure BufferView
bufferView

  let materials :: Vector Material
materials = Vector Material -> Maybe (Vector Material) -> Vector Material
forall a. a -> Maybe a -> a
fromMaybe Vector Material
forall a. Monoid a => a
mempty (Maybe (Vector Material) -> Vector Material)
-> Maybe (Vector Material) -> Vector Material
forall a b. (a -> b) -> a -> b
$ GlTF -> Maybe (Vector Material)
Root.materials GlTF
root

  Vector (Vector MeshPrimitive)
meshPrimitives <- case GlTF -> Maybe (Vector Mesh)
Root.meshes GlTF
root of
    Maybe (Vector Mesh)
Nothing ->
      String -> m (Vector (Vector MeshPrimitive))
forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString (String -> m (Vector (Vector MeshPrimitive)))
-> String -> m (Vector (Vector MeshPrimitive))
forall a b. (a -> b) -> a -> b
$ String
"No meshes in " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
fp
    Just Vector Mesh
meshes ->
      -- XXX: the indices are provided to assist with debugging
      Vector Mesh
-> (Int -> Mesh -> m (Vector MeshPrimitive))
-> m (Vector (Vector MeshPrimitive))
forall (m :: * -> *) a b.
Monad m =>
Vector a -> (Int -> a -> m b) -> m (Vector b)
Vector.iforM Vector Mesh
meshes \Int
_meshIx Mesh
mesh -> do
        Vector MeshPrimitive
-> (Int -> MeshPrimitive -> m MeshPrimitive)
-> m (Vector MeshPrimitive)
forall (m :: * -> *) a b.
Monad m =>
Vector a -> (Int -> a -> m b) -> m (Vector b)
Vector.iforM (Mesh -> Vector MeshPrimitive
Mesh.primitives Mesh
mesh) \Int
_primIx MeshPrimitive
prim -> do
          -- traceShowM
          --   ( "mesh"
          --   , _meshIx, Mesh.name mesh
          --   , "primitive"
          --   , _primIx
          --   )
          case MeshPrimitive -> MeshPrimitiveMode
Mesh.mode MeshPrimitive
prim of
            MeshPrimitiveMode
Mesh.TRIANGLES ->
              () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            MeshPrimitiveMode
mode ->
              String -> m ()
forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Can't load anything but TRIANGLES, got " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> MeshPrimitiveMode -> String
forall a. Show a => a -> String
show MeshPrimitiveMode
mode

          [Word32]
indicesCCW <- case MeshPrimitive -> Maybe AccessorIx
Mesh.indices MeshPrimitive
prim of
            Maybe AccessorIx
Nothing ->
              String -> m [Word32]
forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString String
"No indices for mesh primitive"
            Just AccessorIx
aix -> do
              Accessor.Accessor{ComponentType
componentType :: ComponentType
$sel:componentType:Accessor :: Accessor -> ComponentType
componentType} <- AccessorIx -> m Accessor
getAccessor AccessorIx
aix
              case ComponentType
componentType of
                ComponentType
Accessor.UNSIGNED_INT ->
                  forall a (m :: * -> *).
(MonadThrow m, MonadIO m, Storable a) =>
(AccessorIx -> m Accessor)
-> (BufferViewIx -> m BufferView)
-> (BufferIx -> m ByteString)
-> AttributeType
-> ComponentType
-> AccessorIx
-> m [a]
accessBuffer @Word32 AccessorIx -> m Accessor
getAccessor BufferViewIx -> m BufferView
getBufferView BufferIx -> m ByteString
getBuffer AttributeType
Accessor.SCALAR ComponentType
Accessor.UNSIGNED_INT AccessorIx
aix
                ComponentType
Accessor.UNSIGNED_SHORT ->
                  ([Word16] -> [Word32]) -> m [Word16] -> m [Word32]
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Word16 -> Word32) -> [Word16] -> [Word32]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Word16 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral) (m [Word16] -> m [Word32]) -> m [Word16] -> m [Word32]
forall a b. (a -> b) -> a -> b
$
                    forall a (m :: * -> *).
(MonadThrow m, MonadIO m, Storable a) =>
(AccessorIx -> m Accessor)
-> (BufferViewIx -> m BufferView)
-> (BufferIx -> m ByteString)
-> AttributeType
-> ComponentType
-> AccessorIx
-> m [a]
accessBuffer @Word16 AccessorIx -> m Accessor
getAccessor BufferViewIx -> m BufferView
getBufferView BufferIx -> m ByteString
getBuffer AttributeType
Accessor.SCALAR ComponentType
Accessor.UNSIGNED_SHORT AccessorIx
aix
                ComponentType
Accessor.UNSIGNED_BYTE ->
                  ([Word8] -> [Word32]) -> m [Word8] -> m [Word32]
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Word8 -> Word32) -> [Word8] -> [Word32]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Word8 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral) (m [Word8] -> m [Word32]) -> m [Word8] -> m [Word32]
forall a b. (a -> b) -> a -> b
$
                    forall a (m :: * -> *).
(MonadThrow m, MonadIO m, Storable a) =>
(AccessorIx -> m Accessor)
-> (BufferViewIx -> m BufferView)
-> (BufferIx -> m ByteString)
-> AttributeType
-> ComponentType
-> AccessorIx
-> m [a]
accessBuffer @Word8 AccessorIx -> m Accessor
getAccessor BufferViewIx -> m BufferView
getBufferView BufferIx -> m ByteString
getBuffer AttributeType
Accessor.SCALAR ComponentType
Accessor.UNSIGNED_BYTE AccessorIx
aix
                ComponentType
huh ->
                  UnexpectedComponentType -> m [Word32]
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (UnexpectedComponentType -> m [Word32])
-> UnexpectedComponentType -> m [Word32]
forall a b. (a -> b) -> a -> b
$ AccessorIx
-> ComponentType -> ComponentType -> UnexpectedComponentType
UnexpectedComponentType AccessorIx
aix ComponentType
Accessor.UNSIGNED_INT ComponentType
huh

          (Maybe (Int, Material)
material, [Word32]
indices) <- case MeshPrimitive -> Maybe MaterialIx
Mesh.material MeshPrimitive
prim of
            Maybe MaterialIx
Nothing ->
              (Maybe (Int, Material), [Word32])
-> m (Maybe (Int, Material), [Word32])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Int, Material)
forall a. Maybe a
Nothing, [Word32]
indicesCCW)
            Just (Material.MaterialIx Int
mix) ->
              case Vector Material
materials Vector Material -> Int -> Maybe Material
forall a. Vector a -> Int -> Maybe a
Vector.!? Int
mix of
                Maybe Material
Nothing ->
                  String -> m (Maybe (Int, Material), [Word32])
forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString String
"No material for index"
                Just mat :: Material
mat@Material.Material{Bool
doubleSided :: Bool
$sel:doubleSided:Material :: Material -> Bool
doubleSided} -> do
                  (Maybe (Int, Material), [Word32])
-> m (Maybe (Int, Material), [Word32])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                    ( (Int, Material) -> Maybe (Int, Material)
forall a. a -> Maybe a
Just (Int
mix, Material
mat)
                    , if Bool
doubleSided Bool -> Bool -> Bool
&& Bool
addBacksides then
                        [Word32]
indicesCCW [Word32] -> [Word32] -> [Word32]
forall a. Semigroup a => a -> a -> a
<> [Word32] -> [Word32]
forall a. [a] -> [a]
reverse [Word32]
indicesCCW
                      else
                        if Bool
reverseIndices then
                          [Word32] -> [Word32]
forall a. [a] -> [a]
reverse [Word32]
indicesCCW
                        else
                          [Word32]
indicesCCW
                    )

          -- for (HashMap.toList $ Mesh.attributes prim) \(attr, aix) ->
          --   traceShowM (attr, aix)

          -- let attrKeys = HashMap.keys $ Mesh.attributes prim
          -- logDebug $ "Mesh attributes: " <> displayShow attrKeys

          [Packed]
positions <- case Text -> HashMap Text AccessorIx -> Maybe AccessorIx
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Text
"POSITION" (MeshPrimitive -> HashMap Text AccessorIx
Mesh.attributes MeshPrimitive
prim) of
            Maybe AccessorIx
Nothing ->
              -- XXX: huh?
              String -> m [Packed]
forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString (String -> m [Packed]) -> String -> m [Packed]
forall a b. (a -> b) -> a -> b
$ String
"Mesh primitive without POSITION attribute"
            Just AccessorIx
aix ->
              forall a (m :: * -> *).
(MonadThrow m, MonadIO m, Storable a) =>
(AccessorIx -> m Accessor)
-> (BufferViewIx -> m BufferView)
-> (BufferIx -> m ByteString)
-> AttributeType
-> ComponentType
-> AccessorIx
-> m [a]
accessBuffer @Vec3.Packed AccessorIx -> m Accessor
getAccessor BufferViewIx -> m BufferView
getBufferView BufferIx -> m ByteString
getBuffer AttributeType
Accessor.VEC3 ComponentType
Accessor.FLOAT AccessorIx
aix
          -- logDebug $ "POSITION (" <> display (length positions) <> ") " <> displayShow (take 10 $ fmap Vec3.unPacked positions)

          -- traceShowM
          --   ( ( meshIx
          --     , primIx
          --     )
          --   , length positions
          --   , ( length indices
          --     , minimum indices
          --     , maximum indices
          --     )
          --   )

          [Packed]
normals <- case Text -> HashMap Text AccessorIx -> Maybe AccessorIx
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Text
"NORMAL" (MeshPrimitive -> HashMap Text AccessorIx
Mesh.attributes MeshPrimitive
prim) of
            Maybe AccessorIx
Nothing -> do
              Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"Mesh primitive without NORMAL attribute"
              pure $ Int -> [Packed] -> [Packed]
forall a. Int -> [a] -> [a]
take ([Packed] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Packed]
positions) ([Packed] -> [Packed]) -> [Packed] -> [Packed]
forall a b. (a -> b) -> a -> b
$ Packed -> [Packed]
forall a. a -> [a]
List.repeat (Vec3 -> Packed
Vec3.Packed Vec3
0)
            Just AccessorIx
aix ->
              forall a (m :: * -> *).
(MonadThrow m, MonadIO m, Storable a) =>
(AccessorIx -> m Accessor)
-> (BufferViewIx -> m BufferView)
-> (BufferIx -> m ByteString)
-> AttributeType
-> ComponentType
-> AccessorIx
-> m [a]
accessBuffer @Vec3.Packed AccessorIx -> m Accessor
getAccessor BufferViewIx -> m BufferView
getBufferView BufferIx -> m ByteString
getBuffer AttributeType
Accessor.VEC3 ComponentType
Accessor.FLOAT AccessorIx
aix
          -- logDebug $ "NORMAL (" <> display (length normals) <> ") " <> displayShow (take 10 normals)

          [Vec2]
texCoords0 <- case Text -> HashMap Text AccessorIx -> Maybe AccessorIx
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Text
"TEXCOORD_0" (MeshPrimitive -> HashMap Text AccessorIx
Mesh.attributes MeshPrimitive
prim) of
            Maybe AccessorIx
Nothing -> do
              Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Mesh primitive without TEXCOORD_0 attribute"
              pure $ Int -> [Vec2] -> [Vec2]
forall a. Int -> [a] -> [a]
take ([Packed] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Packed]
positions) ([Vec2] -> [Vec2]) -> [Vec2] -> [Vec2]
forall a b. (a -> b) -> a -> b
$ Vec2 -> [Vec2]
forall a. a -> [a]
List.repeat Vec2
0
            Just AccessorIx
aix ->
              forall a (m :: * -> *).
(MonadThrow m, MonadIO m, Storable a) =>
(AccessorIx -> m Accessor)
-> (BufferViewIx -> m BufferView)
-> (BufferIx -> m ByteString)
-> AttributeType
-> ComponentType
-> AccessorIx
-> m [a]
accessBuffer @Vec2 AccessorIx -> m Accessor
getAccessor BufferViewIx -> m BufferView
getBufferView BufferIx -> m ByteString
getBuffer AttributeType
Accessor.VEC2 ComponentType
Accessor.FLOAT AccessorIx
aix
          -- logDebug $ "TEXCOORD_0 (" <> display (length texCoords0) <> ") " <> displayShow (take 10 texCoords0)

          [Vec4]
tangents <- case Text -> HashMap Text AccessorIx -> Maybe AccessorIx
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Text
"TANGENT" (MeshPrimitive -> HashMap Text AccessorIx
Mesh.attributes MeshPrimitive
prim) of
            Just AccessorIx
aix ->
              forall a (m :: * -> *).
(MonadThrow m, MonadIO m, Storable a) =>
(AccessorIx -> m Accessor)
-> (BufferViewIx -> m BufferView)
-> (BufferIx -> m ByteString)
-> AttributeType
-> ComponentType
-> AccessorIx
-> m [a]
accessBuffer @Vec4 AccessorIx -> m Accessor
getAccessor BufferViewIx -> m BufferView
getBufferView BufferIx -> m ByteString
getBuffer AttributeType
Accessor.VEC4 ComponentType
Accessor.FLOAT AccessorIx
aix
            Maybe AccessorIx
Nothing -> do
              -- logDebug "Mesh primitive without TANGENT attribute"
              [Vec4] -> m [Vec4]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Vec4] -> m [Vec4]) -> [Vec4] -> m [Vec4]
forall a b. (a -> b) -> a -> b
$ Int -> [Vec4] -> [Vec4]
forall a. Int -> [a] -> [a]
take ([Packed] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Packed]
positions) ([Vec4] -> [Vec4]) -> [Vec4] -> [Vec4]
forall a b. (a -> b) -> a -> b
$ Vec4 -> [Vec4]
forall a. a -> [a]
List.repeat Vec4
0
          -- logDebug $ "TANGENT (" <> display (length tangents) <> ") " <> displayShow (take 10 tangents)

          let
            attrs :: [VertexAttrs]
attrs = do
              (Vec2
tc0, Packed
norm, Vec4
tangent') <- [Vec2] -> [Packed] -> [Vec4] -> [(Vec2, Packed, Vec4)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
List.zip3 [Vec2]
texCoords0 [Packed]
normals [Vec4]
tangents
              let
                tangent :: Packed
tangent =
                  Vec4 -> (Float -> Float -> Float -> Float -> Packed) -> Packed
forall r. Vec4 -> (Float -> Float -> Float -> Float -> r) -> r
withVec4 Vec4
tangent' \Float
tx Float
ty Float
tz Float
_handedness ->
                    Vec3 -> Packed
Vec3.Packed (Vec3 -> Packed) -> Vec3 -> Packed
forall a b. (a -> b) -> a -> b
$ Float -> Float -> Float -> Vec3
vec3 Float
tx Float
ty Float
tz
              VertexAttrs -> [VertexAttrs]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure VertexAttrs
                { $sel:vaTexCoord:VertexAttrs :: Vec2
vaTexCoord = Vec2
tc0
                , $sel:vaNormal:VertexAttrs :: Packed
vaNormal   = Packed
norm
                , $sel:vaTangent:VertexAttrs :: Packed
vaTangent  = Packed
tangent
                }
          pure
            ( Maybe (Int, Material)
material
            , Stuff
                { $sel:sPositions:Stuff :: Vector Packed
sPositions = [Packed] -> Vector Packed
forall a. [a] -> Vector a
Vector.fromList [Packed]
positions
                , $sel:sAttrs:Stuff :: Vector VertexAttrs
sAttrs     = [VertexAttrs] -> Vector VertexAttrs
forall a. [a] -> Vector a
Vector.fromList [VertexAttrs]
attrs
                , $sel:sIndices:Stuff :: Vector Word32
sIndices   = [Word32] -> Vector Word32
forall a. [a] -> Vector a
Vector.fromList [Word32]
indices
                }
            )

  pure (GlTF
root, Vector (Vector MeshPrimitive)
meshPrimitives)

accessBuffer
  :: forall a m
  .  ( MonadThrow m
     , MonadIO m
     , Storable a
     )
  => (Accessor.AccessorIx -> m Accessor.Accessor)
  -> (BufferView.BufferViewIx -> m BufferView.BufferView)
  -> (Buffer.BufferIx -> m ByteString)
  -> Accessor.AttributeType
  -> Accessor.ComponentType
  -> Accessor.AccessorIx
  -> m [a]
accessBuffer :: forall a (m :: * -> *).
(MonadThrow m, MonadIO m, Storable a) =>
(AccessorIx -> m Accessor)
-> (BufferViewIx -> m BufferView)
-> (BufferIx -> m ByteString)
-> AttributeType
-> ComponentType
-> AccessorIx
-> m [a]
accessBuffer AccessorIx -> m Accessor
getAccessor BufferViewIx -> m BufferView
getBufferView BufferIx -> m ByteString
getBuffer AttributeType
expectAttribute ComponentType
expectComponent AccessorIx
aix = do
  Accessor.Accessor{Maybe BufferViewIx
bufferView :: Maybe BufferViewIx
$sel:bufferView:Accessor :: Accessor -> Maybe BufferViewIx
bufferView, $sel:byteOffset:Accessor :: Accessor -> Int
byteOffset=Int
accOffset, ComponentType
$sel:componentType:Accessor :: Accessor -> ComponentType
componentType :: ComponentType
componentType, Int
count :: Int
$sel:count:Accessor :: Accessor -> Int
count, AttributeType
type' :: AttributeType
$sel:type':Accessor :: Accessor -> AttributeType
type'} <- AccessorIx -> m Accessor
getAccessor AccessorIx
aix

  bv :: BufferView
bv@BufferView.BufferView{$sel:byteOffset:BufferView :: BufferView -> Int
byteOffset=Int
bufOffset, Int
byteLength :: Int
$sel:byteLength:BufferView :: BufferView -> Int
byteLength} <- case Maybe BufferViewIx
bufferView of
    Maybe BufferViewIx
Nothing ->
      String -> m BufferView
forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString (String -> m BufferView) -> String -> m BufferView
forall a b. (a -> b) -> a -> b
$ String
"No bufferView for index accessor " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> AccessorIx -> String
forall a. Show a => a -> String
show AccessorIx
aix
    Just BufferViewIx
bvix ->
      BufferViewIx -> m BufferView
getBufferView BufferViewIx
bvix

  ByteString
buffer <- BufferIx -> m ByteString
getBuffer (BufferView -> BufferIx
BufferView.buffer BufferView
bv)

  (AttributeType -> AttributeType -> UnexpectedAttributeType)
-> AttributeType -> AttributeType -> m ()
forall e exception (m :: * -> *).
(Eq e, Exception exception, MonadThrow m) =>
(e -> e -> exception) -> e -> e -> m ()
unexpected (AccessorIx
-> AttributeType -> AttributeType -> UnexpectedAttributeType
UnexpectedAttributeType AccessorIx
aix) AttributeType
expectAttribute AttributeType
type'
  (ComponentType -> ComponentType -> UnexpectedComponentType)
-> ComponentType -> ComponentType -> m ()
forall e exception (m :: * -> *).
(Eq e, Exception exception, MonadThrow m) =>
(e -> e -> exception) -> e -> e -> m ()
unexpected (AccessorIx
-> ComponentType -> ComponentType -> UnexpectedComponentType
UnexpectedComponentType AccessorIx
aix) ComponentType
expectComponent ComponentType
componentType
  let strideSize :: Int
strideSize = a -> Int
forall a. Storable a => a -> Int
Foreign.sizeOf (String -> a
forall a. HasCallStack => String -> a
error String
"strideSize.sizeOf" :: a)
  case BufferView -> Maybe Int
BufferView.byteStride BufferView
bv of
    Maybe Int
Nothing ->
      () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Just Int
stride
      | Int
stride Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
strideSize ->
          () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Just Int
stride ->
      (Int -> Int -> UnexpectedBufferViewStride) -> Int -> Int -> m ()
forall e exception (m :: * -> *).
(Eq e, Exception exception, MonadThrow m) =>
(e -> e -> exception) -> e -> e -> m ()
unexpected (AccessorIx -> Int -> Int -> UnexpectedBufferViewStride
UnexpectedBufferViewStride AccessorIx
aix) Int
strideSize Int
stride

  let bytes :: ByteString
bytes = Int -> ByteString -> ByteString
ByteString.take Int
byteLength (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
ByteString.drop (Int
accOffset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
bufOffset) ByteString
buffer
  IO [a] -> m [a]
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [a] -> m [a])
-> ((CString -> IO [a]) -> IO [a]) -> (CString -> IO [a]) -> m [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> (CString -> IO [a]) -> IO [a]
forall a. ByteString -> (CString -> IO a) -> IO a
ByteString.unsafeUseAsCString ByteString
bytes ((CString -> IO [a]) -> m [a]) -> (CString -> IO [a]) -> m [a]
forall a b. (a -> b) -> a -> b
$
    Int -> Ptr a -> IO [a]
forall a. Storable a => Int -> Ptr a -> IO [a]
Foreign.peekArray Int
count (Ptr a -> IO [a]) -> (CString -> Ptr a) -> CString -> IO [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CString -> Ptr a
forall a b. Ptr a -> Ptr b
Foreign.castPtr

unexpected
  :: (Eq e, Exception exception, MonadThrow m)
  => (e -> e -> exception)
  -> e
  -> e
  -> m ()
unexpected :: forall e exception (m :: * -> *).
(Eq e, Exception exception, MonadThrow m) =>
(e -> e -> exception) -> e -> e -> m ()
unexpected e -> e -> exception
cons e
expected e
got =
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (e
expected e -> e -> Bool
forall a. Eq a => a -> a -> Bool
== e
got) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    exception -> m ()
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (exception -> m ()) -> exception -> m ()
forall a b. (a -> b) -> a -> b
$ e -> e -> exception
cons e
expected e
got

data UnexpectedAttributeType = UnexpectedAttributeType
  { UnexpectedAttributeType -> AccessorIx
uatAccessor :: Accessor.AccessorIx
  , UnexpectedAttributeType -> AttributeType
uatExpected :: Accessor.AttributeType
  , UnexpectedAttributeType -> AttributeType
uatGot      :: Accessor.AttributeType
  }
  deriving (UnexpectedAttributeType -> UnexpectedAttributeType -> Bool
(UnexpectedAttributeType -> UnexpectedAttributeType -> Bool)
-> (UnexpectedAttributeType -> UnexpectedAttributeType -> Bool)
-> Eq UnexpectedAttributeType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: UnexpectedAttributeType -> UnexpectedAttributeType -> Bool
== :: UnexpectedAttributeType -> UnexpectedAttributeType -> Bool
$c/= :: UnexpectedAttributeType -> UnexpectedAttributeType -> Bool
/= :: UnexpectedAttributeType -> UnexpectedAttributeType -> Bool
Eq, Eq UnexpectedAttributeType
Eq UnexpectedAttributeType
-> (UnexpectedAttributeType -> UnexpectedAttributeType -> Ordering)
-> (UnexpectedAttributeType -> UnexpectedAttributeType -> Bool)
-> (UnexpectedAttributeType -> UnexpectedAttributeType -> Bool)
-> (UnexpectedAttributeType -> UnexpectedAttributeType -> Bool)
-> (UnexpectedAttributeType -> UnexpectedAttributeType -> Bool)
-> (UnexpectedAttributeType
    -> UnexpectedAttributeType -> UnexpectedAttributeType)
-> (UnexpectedAttributeType
    -> UnexpectedAttributeType -> UnexpectedAttributeType)
-> Ord UnexpectedAttributeType
UnexpectedAttributeType -> UnexpectedAttributeType -> Bool
UnexpectedAttributeType -> UnexpectedAttributeType -> Ordering
UnexpectedAttributeType
-> UnexpectedAttributeType -> UnexpectedAttributeType
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: UnexpectedAttributeType -> UnexpectedAttributeType -> Ordering
compare :: UnexpectedAttributeType -> UnexpectedAttributeType -> Ordering
$c< :: UnexpectedAttributeType -> UnexpectedAttributeType -> Bool
< :: UnexpectedAttributeType -> UnexpectedAttributeType -> Bool
$c<= :: UnexpectedAttributeType -> UnexpectedAttributeType -> Bool
<= :: UnexpectedAttributeType -> UnexpectedAttributeType -> Bool
$c> :: UnexpectedAttributeType -> UnexpectedAttributeType -> Bool
> :: UnexpectedAttributeType -> UnexpectedAttributeType -> Bool
$c>= :: UnexpectedAttributeType -> UnexpectedAttributeType -> Bool
>= :: UnexpectedAttributeType -> UnexpectedAttributeType -> Bool
$cmax :: UnexpectedAttributeType
-> UnexpectedAttributeType -> UnexpectedAttributeType
max :: UnexpectedAttributeType
-> UnexpectedAttributeType -> UnexpectedAttributeType
$cmin :: UnexpectedAttributeType
-> UnexpectedAttributeType -> UnexpectedAttributeType
min :: UnexpectedAttributeType
-> UnexpectedAttributeType -> UnexpectedAttributeType
Ord, Int -> UnexpectedAttributeType -> String -> String
[UnexpectedAttributeType] -> String -> String
UnexpectedAttributeType -> String
(Int -> UnexpectedAttributeType -> String -> String)
-> (UnexpectedAttributeType -> String)
-> ([UnexpectedAttributeType] -> String -> String)
-> Show UnexpectedAttributeType
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> UnexpectedAttributeType -> String -> String
showsPrec :: Int -> UnexpectedAttributeType -> String -> String
$cshow :: UnexpectedAttributeType -> String
show :: UnexpectedAttributeType -> String
$cshowList :: [UnexpectedAttributeType] -> String -> String
showList :: [UnexpectedAttributeType] -> String -> String
Show)

instance Exception UnexpectedAttributeType

data UnexpectedComponentType = UnexpectedComponentType
  { UnexpectedComponentType -> AccessorIx
uctAccessor :: Accessor.AccessorIx
  , UnexpectedComponentType -> ComponentType
uctExpected :: Accessor.ComponentType
  , UnexpectedComponentType -> ComponentType
uctGot      :: Accessor.ComponentType
  }
  deriving (UnexpectedComponentType -> UnexpectedComponentType -> Bool
(UnexpectedComponentType -> UnexpectedComponentType -> Bool)
-> (UnexpectedComponentType -> UnexpectedComponentType -> Bool)
-> Eq UnexpectedComponentType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: UnexpectedComponentType -> UnexpectedComponentType -> Bool
== :: UnexpectedComponentType -> UnexpectedComponentType -> Bool
$c/= :: UnexpectedComponentType -> UnexpectedComponentType -> Bool
/= :: UnexpectedComponentType -> UnexpectedComponentType -> Bool
Eq, Eq UnexpectedComponentType
Eq UnexpectedComponentType
-> (UnexpectedComponentType -> UnexpectedComponentType -> Ordering)
-> (UnexpectedComponentType -> UnexpectedComponentType -> Bool)
-> (UnexpectedComponentType -> UnexpectedComponentType -> Bool)
-> (UnexpectedComponentType -> UnexpectedComponentType -> Bool)
-> (UnexpectedComponentType -> UnexpectedComponentType -> Bool)
-> (UnexpectedComponentType
    -> UnexpectedComponentType -> UnexpectedComponentType)
-> (UnexpectedComponentType
    -> UnexpectedComponentType -> UnexpectedComponentType)
-> Ord UnexpectedComponentType
UnexpectedComponentType -> UnexpectedComponentType -> Bool
UnexpectedComponentType -> UnexpectedComponentType -> Ordering
UnexpectedComponentType
-> UnexpectedComponentType -> UnexpectedComponentType
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: UnexpectedComponentType -> UnexpectedComponentType -> Ordering
compare :: UnexpectedComponentType -> UnexpectedComponentType -> Ordering
$c< :: UnexpectedComponentType -> UnexpectedComponentType -> Bool
< :: UnexpectedComponentType -> UnexpectedComponentType -> Bool
$c<= :: UnexpectedComponentType -> UnexpectedComponentType -> Bool
<= :: UnexpectedComponentType -> UnexpectedComponentType -> Bool
$c> :: UnexpectedComponentType -> UnexpectedComponentType -> Bool
> :: UnexpectedComponentType -> UnexpectedComponentType -> Bool
$c>= :: UnexpectedComponentType -> UnexpectedComponentType -> Bool
>= :: UnexpectedComponentType -> UnexpectedComponentType -> Bool
$cmax :: UnexpectedComponentType
-> UnexpectedComponentType -> UnexpectedComponentType
max :: UnexpectedComponentType
-> UnexpectedComponentType -> UnexpectedComponentType
$cmin :: UnexpectedComponentType
-> UnexpectedComponentType -> UnexpectedComponentType
min :: UnexpectedComponentType
-> UnexpectedComponentType -> UnexpectedComponentType
Ord, Int -> UnexpectedComponentType -> String -> String
[UnexpectedComponentType] -> String -> String
UnexpectedComponentType -> String
(Int -> UnexpectedComponentType -> String -> String)
-> (UnexpectedComponentType -> String)
-> ([UnexpectedComponentType] -> String -> String)
-> Show UnexpectedComponentType
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> UnexpectedComponentType -> String -> String
showsPrec :: Int -> UnexpectedComponentType -> String -> String
$cshow :: UnexpectedComponentType -> String
show :: UnexpectedComponentType -> String
$cshowList :: [UnexpectedComponentType] -> String -> String
showList :: [UnexpectedComponentType] -> String -> String
Show)

instance Exception UnexpectedComponentType

data UnexpectedBufferViewStride = UnexpectedBufferViewStride
  { UnexpectedBufferViewStride -> AccessorIx
ubvsAccessor :: Accessor.AccessorIx
  , UnexpectedBufferViewStride -> Int
ubvsExpected :: Int
  , UnexpectedBufferViewStride -> Int
ubvsGot      :: Int
  }
  deriving (UnexpectedBufferViewStride -> UnexpectedBufferViewStride -> Bool
(UnexpectedBufferViewStride -> UnexpectedBufferViewStride -> Bool)
-> (UnexpectedBufferViewStride
    -> UnexpectedBufferViewStride -> Bool)
-> Eq UnexpectedBufferViewStride
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: UnexpectedBufferViewStride -> UnexpectedBufferViewStride -> Bool
== :: UnexpectedBufferViewStride -> UnexpectedBufferViewStride -> Bool
$c/= :: UnexpectedBufferViewStride -> UnexpectedBufferViewStride -> Bool
/= :: UnexpectedBufferViewStride -> UnexpectedBufferViewStride -> Bool
Eq, Eq UnexpectedBufferViewStride
Eq UnexpectedBufferViewStride
-> (UnexpectedBufferViewStride
    -> UnexpectedBufferViewStride -> Ordering)
-> (UnexpectedBufferViewStride
    -> UnexpectedBufferViewStride -> Bool)
-> (UnexpectedBufferViewStride
    -> UnexpectedBufferViewStride -> Bool)
-> (UnexpectedBufferViewStride
    -> UnexpectedBufferViewStride -> Bool)
-> (UnexpectedBufferViewStride
    -> UnexpectedBufferViewStride -> Bool)
-> (UnexpectedBufferViewStride
    -> UnexpectedBufferViewStride -> UnexpectedBufferViewStride)
-> (UnexpectedBufferViewStride
    -> UnexpectedBufferViewStride -> UnexpectedBufferViewStride)
-> Ord UnexpectedBufferViewStride
UnexpectedBufferViewStride -> UnexpectedBufferViewStride -> Bool
UnexpectedBufferViewStride
-> UnexpectedBufferViewStride -> Ordering
UnexpectedBufferViewStride
-> UnexpectedBufferViewStride -> UnexpectedBufferViewStride
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: UnexpectedBufferViewStride
-> UnexpectedBufferViewStride -> Ordering
compare :: UnexpectedBufferViewStride
-> UnexpectedBufferViewStride -> Ordering
$c< :: UnexpectedBufferViewStride -> UnexpectedBufferViewStride -> Bool
< :: UnexpectedBufferViewStride -> UnexpectedBufferViewStride -> Bool
$c<= :: UnexpectedBufferViewStride -> UnexpectedBufferViewStride -> Bool
<= :: UnexpectedBufferViewStride -> UnexpectedBufferViewStride -> Bool
$c> :: UnexpectedBufferViewStride -> UnexpectedBufferViewStride -> Bool
> :: UnexpectedBufferViewStride -> UnexpectedBufferViewStride -> Bool
$c>= :: UnexpectedBufferViewStride -> UnexpectedBufferViewStride -> Bool
>= :: UnexpectedBufferViewStride -> UnexpectedBufferViewStride -> Bool
$cmax :: UnexpectedBufferViewStride
-> UnexpectedBufferViewStride -> UnexpectedBufferViewStride
max :: UnexpectedBufferViewStride
-> UnexpectedBufferViewStride -> UnexpectedBufferViewStride
$cmin :: UnexpectedBufferViewStride
-> UnexpectedBufferViewStride -> UnexpectedBufferViewStride
min :: UnexpectedBufferViewStride
-> UnexpectedBufferViewStride -> UnexpectedBufferViewStride
Ord, Int -> UnexpectedBufferViewStride -> String -> String
[UnexpectedBufferViewStride] -> String -> String
UnexpectedBufferViewStride -> String
(Int -> UnexpectedBufferViewStride -> String -> String)
-> (UnexpectedBufferViewStride -> String)
-> ([UnexpectedBufferViewStride] -> String -> String)
-> Show UnexpectedBufferViewStride
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> UnexpectedBufferViewStride -> String -> String
showsPrec :: Int -> UnexpectedBufferViewStride -> String -> String
$cshow :: UnexpectedBufferViewStride -> String
show :: UnexpectedBufferViewStride -> String
$cshowList :: [UnexpectedBufferViewStride] -> String -> String
showList :: [UnexpectedBufferViewStride] -> String -> String
Show)

instance Exception UnexpectedBufferViewStride