packages feed

gltf-codec (empty) → 0.1.0.1

raw patch · 27 files changed

+1412/−0 lines, 27 filesdep +aesondep +basedep +base64-bytestringsetup-changed

Dependencies added: aeson, base, base64-bytestring, binary, bytestring, directory, filepath, gltf-codec, scientific, shower, text, unordered-containers, vector

Files

+ ChangeLog.md view
@@ -0,0 +1,14 @@+# Changelog for `gltf-codec`++## Unreleased changes++## [0.1.0.1] - 2020-06-21++* Added pattern synonyms for newtyped "allowed values".++## [0.1.0.0] - 2020-06-07++* Initial import.++[0.1.0.1]: https://gitlab.com/dpwiz/gltf/tree/v0.1.0.1+[0.1.0.0]: https://gitlab.com/dpwiz/gltf/tree/v0.1.0.0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Alexander Bondarenko (c) 2020++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * 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.++    * Neither the name of Alexander Bondarenko nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"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 COPYRIGHT+OWNER 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.
+ README.md view
@@ -0,0 +1,1 @@+# gltf
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ gltf-codec.cabal view
@@ -0,0 +1,85 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.33.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: d999cb91b06d0be5cac1d0bcc4f794a7d8acb692a0265b6b8642b4fb7366c33f++name:           gltf-codec+version:        0.1.0.1+synopsis:       glTF scene loader+description:    The package provides basic types to process JSON and "binary" files.+                No further conversion is performed to keep dependencies to a minimum.+category:       Graphics+author:         Alexander Bondarenko+maintainer:     aenor.realm@gmail.com+copyright:      2020 Alexander Bondarenko+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    ChangeLog.md++source-repository head+  type: git+  location: https://gitlab.com/dpwiz/gltf++library+  exposed-modules:+      Codec.GLB+      Codec.GlTF+      Codec.GlTF.Accessor+      Codec.GlTF.Animation+      Codec.GlTF.Asset+      Codec.GlTF.Buffer+      Codec.GlTF.BufferView+      Codec.GlTF.Camera+      Codec.GlTF.Image+      Codec.GlTF.Material+      Codec.GlTF.Mesh+      Codec.GlTF.Node+      Codec.GlTF.PbrMetallicRoughness+      Codec.GlTF.Prelude+      Codec.GlTF.Root+      Codec.GlTF.Sampler+      Codec.GlTF.Scene+      Codec.GlTF.Skin+      Codec.GlTF.Texture+      Codec.GlTF.TextureInfo+      Codec.GlTF.URI+  other-modules:+      Paths_gltf_codec+  hs-source-dirs:+      src+  default-extensions: ApplicativeDo BlockArguments DeriveGeneric DuplicateRecordFields FlexibleContexts GeneralizedNewtypeDeriving LambdaCase OverloadedStrings PatternSynonyms RecordWildCards StrictData+  build-depends:+      aeson >=1.4 && <1.5+    , base >=4.7 && <5+    , base64-bytestring >=1 && <2+    , binary >=0.8.7 && <1+    , bytestring >=0.10 && <0.11+    , scientific >=0.3.6 && <0.4+    , text >=1.2 && <1.3+    , unordered-containers >=0.2.10 && <0.3+    , vector >=0.12 && <0.13+  default-language: Haskell2010++test-suite gltf-codec-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Paths_gltf_codec+  hs-source-dirs:+      test+  default-extensions: ApplicativeDo BlockArguments DeriveGeneric DuplicateRecordFields FlexibleContexts GeneralizedNewtypeDeriving LambdaCase OverloadedStrings PatternSynonyms RecordWildCards StrictData+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base >=4.7 && <5+    , bytestring >=0.10 && <0.11+    , directory >=1.3 && <1.4+    , filepath >=1.4 && <1.5+    , gltf-codec+    , shower >=0.2 && <0.3+  default-language: Haskell2010
+ src/Codec/GLB.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StrictData #-}++module Codec.GLB where++import Prelude hiding (length)++import Data.Binary (Binary(..), decodeFileOrFail)+import Data.Binary.Get (ByteOffset, getWord32le, getByteString, isEmpty)+import Data.Binary.Put (putByteString, putWord32le)+import Data.ByteString (ByteString)+import Data.Vector (Vector, unfoldrM)+import Data.Word (Word32)+import GHC.Generics (Generic)++fromFile :: FilePath -> IO (Either (ByteOffset, String) GLB)+fromFile = decodeFileOrFail++data GLB = GLB+  { header :: Header+  , chunks :: Vector Chunk+  } deriving (Eq, Show, Generic)++instance Binary GLB where+  get = GLB <$> get <*> unfoldrM getChunks ()+    where+      getChunks () = do+        done <- isEmpty+        if done then+          pure Nothing+        else do+          chunk <- get+          pure $ Just (chunk, ())++  put GLB{..} = do+    put header+    mapM_ put chunks++data Header = Header+  { magic   :: Word32+  , version :: Word32+  , length  :: Word32+  } deriving (Eq, Show, Generic)++instance Binary Header where+  get = Header+    <$> getWord32le+    <*> getWord32le+    <*> getWord32le++  put Header{..} = do+    putWord32le magic+    putWord32le version+    putWord32le length++data Chunk = Chunk+  { chunkLength :: Word32+  , chunkType   :: Word32+  , chunkData   :: ByteString+  }+  deriving (Eq, Show, Generic)++instance Binary Chunk where+  get = do+    chunkLength <- getWord32le+    chunkType   <- getWord32le+    chunkData   <- getByteString (fromIntegral chunkLength)+    pure Chunk{..}++  put Chunk{..} = do+    putWord32le   chunkLength+    putWord32le   chunkType+    putByteString chunkData
+ src/Codec/GlTF.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-}++module Codec.GlTF+  ( GlTF(..)+  , fromFile+  , fromChunk+  ) where++import qualified Data.Aeson as JSON++import Codec.GlTF.Root (GlTF(..))++import qualified Codec.GLB  as GLB++fromFile :: FilePath -> IO (Either String GlTF)+fromFile = JSON.eitherDecodeFileStrict'++fromChunk :: GLB.Chunk -> Either String GlTF+fromChunk = JSON.eitherDecodeStrict' . GLB.chunkData
+ src/Codec/GlTF/Accessor.hs view
@@ -0,0 +1,145 @@+module Codec.GlTF.Accessor+  ( AccessorIx(..)+  , Accessor(..)++  , AccessorSparse(..)+  , AccessorSparseIndices(..)+  , AccessorSparseValues(..)++  , ComponentType(..)+  , pattern BYTE+  , pattern UNSIGNED_BYTE+  , pattern SHORT+  , pattern UNSIGNED_SHORT+  , pattern UNSIGNED_INT+  , pattern FLOAT++  , AttributeType(..)+  , pattern SCALAR+  , pattern VEC2+  , pattern VEC3+  , pattern VEC4+  , pattern MAT2+  , pattern MAT3+  , pattern MAT4+  ) where++import Prelude hiding (min, max)+import Codec.GlTF.Prelude++import Codec.GlTF.BufferView (BufferViewIx)++newtype AccessorIx = AccessorIx { unAccessorIx :: Int }+  deriving (Eq, Ord, Show, FromJSON, ToJSON, Generic)++-- | The root object for a glTF Accessor.+data Accessor = Accessor+  { componentType :: ComponentType+  , normalized    :: Bool+  , byteOffset    :: Size+  , count         :: Size+  , type'         :: AttributeType++  , bufferView    :: Maybe BufferViewIx+  , min           :: Maybe (Vector Scientific)+  , max           :: Maybe (Vector Scientific)+  , sparse        :: Maybe AccessorSparse++  , name       :: Maybe Text+  , extensions :: Maybe Object+  , extras     :: Maybe Value+  } deriving (Eq, Show, Generic)++instance FromJSON Accessor where+  parseJSON = withObject "Accessor" \o -> do+    bufferView    <- o .:? "bufferView"+    byteOffset    <- o .:? "byteOffset" .!= 0+    componentType <- o .:  "componentType"+    normalized    <- o .:? "normalized" .!= False+    count         <- o .:  "count"+    type'         <- o .:  "type"+    min           <- o .:? "min"+    max           <- o .:? "max"+    sparse        <- o .:? "sparse"+    name          <- o .:? "name"+    extensions    <- o .:? "extensions"+    extras        <- o .:? "extras"+    pure Accessor{..}++instance ToJSON Accessor where+  toJSON = gToJSON++newtype ComponentType = ComponentType { unComponentType :: Int }+  deriving (Eq, Ord, Show, FromJSON, ToJSON, Generic)++pattern BYTE :: ComponentType+pattern BYTE = ComponentType 5120++pattern UNSIGNED_BYTE :: ComponentType+pattern UNSIGNED_BYTE = ComponentType 5121++pattern SHORT :: ComponentType+pattern SHORT = ComponentType 5122++pattern UNSIGNED_SHORT :: ComponentType+pattern UNSIGNED_SHORT = ComponentType 5123++pattern UNSIGNED_INT :: ComponentType+pattern UNSIGNED_INT = ComponentType 5125++pattern FLOAT :: ComponentType+pattern FLOAT = ComponentType 5126++newtype AttributeType = AttributeType { unAttributeType :: Text }+  deriving (Eq, Ord, Show, FromJSON, ToJSON, Generic)++pattern SCALAR :: AttributeType+pattern SCALAR = AttributeType "SCALAR"++pattern VEC2 :: AttributeType+pattern VEC2 = AttributeType "VEC2"++pattern VEC3 :: AttributeType+pattern VEC3 = AttributeType "VEC3"++pattern VEC4 :: AttributeType+pattern VEC4 = AttributeType "VEC4"++pattern MAT2 :: AttributeType+pattern MAT2 = AttributeType "MAT2"++pattern MAT3 :: AttributeType+pattern MAT3 = AttributeType "MAT3"++pattern MAT4 :: AttributeType+pattern MAT4 = AttributeType "MAT4"++-- | Sparse storage of attributes that deviate from their initialization value.+data AccessorSparse = AccessorSparse+  { count   :: Size+  , indices :: AccessorSparseIndices+  , values  :: AccessorSparseValues+  } deriving (Eq, Show, Generic)++instance FromJSON AccessorSparse+instance ToJSON AccessorSparse++-- | Indices of those attributes that deviate from their initialization value.+data AccessorSparseIndices = AccessorSparseIndices+  { bufferView    :: Maybe BufferViewIx+  , byteOffset    :: Size+  , componentType :: ComponentType+  } deriving (Eq, Show, Generic)++instance FromJSON AccessorSparseIndices+instance ToJSON AccessorSparseIndices++-- | Array of size @accessor.sparse.count@ times number of components storing+-- the displaced accessor attributes pointed by @accessor.sparse.indices@.+data AccessorSparseValues = AccessorSparseValues+  { bufferView :: Maybe BufferViewIx+  , byteOffset :: Size+  } deriving (Eq, Show, Generic)++instance FromJSON AccessorSparseValues+instance ToJSON AccessorSparseValues
+ src/Codec/GlTF/Animation.hs view
@@ -0,0 +1,126 @@+module Codec.GlTF.Animation+  ( AnimationIx(..)+  , Animation(..)++  , AnimationSamplerIx(..)+  , AnimationSampler(..)+  , AnimationSamplerInterpolation(..)+  , pattern LINEAR+  , pattern STEP+  , pattern CUBICSPLINE++  , AnimationChannel(..)++  , AnimationChannelTarget(..)+  , AnimationChannelTargetPath(..)+  , pattern TRANSLATION+  , pattern ROTATION+  , pattern SCALE+  , pattern WEIGHTS+  ) where++import Codec.GlTF.Prelude++import Codec.GlTF.Accessor (AccessorIx)+import Codec.GlTF.Node (NodeIx)++newtype AnimationIx = AnimationIx { unAnimationIx :: Int }+  deriving (Eq, Ord, Show, FromJSON, ToJSON, Generic)++-- | A keyframe animation.+data Animation = Animation+  { channels :: Vector AnimationChannel+  , samplers :: Vector AnimationSampler++  , name       :: Maybe Text+  , extensions :: Maybe Object+  , extras     :: Maybe Value+  } deriving (Eq, Show, Generic)++instance FromJSON Animation+instance ToJSON Animation++newtype AnimationSamplerIx = AnimationSamplerIx { unAnimationSamplerIx :: Int }+  deriving (Eq, Ord, Show, FromJSON, ToJSON, Generic)++-- | Combines input and output accessors with an interpolation algorithm+-- to define a keyframe graph (but not its target).+data AnimationSampler = AnimationSampler+  { input         :: AccessorIx+    -- ^ The values represent time in seconds with @time[0] >= 0.0@,+    -- and strictly increasing values.+  , interpolation :: AnimationSamplerInterpolation+  , output        :: AccessorIx+    -- ^ The index of an accessor containing keyframe output values.+  , extensions    :: Maybe Object+  , extras        :: Maybe Value+  } deriving (Eq, Show, Generic)++instance FromJSON AnimationSampler where+  parseJSON = withObject "AnimationSampler" \o -> do+    input         <- o .:  "input"+    interpolation <- o .:? "interpolation" .!= LINEAR+    output        <- o .:  "output"+    extensions    <- o .:? "extensions"+    extras        <- o .:? "extras"++    pure AnimationSampler{..}++instance ToJSON AnimationSampler++newtype AnimationSamplerInterpolation = AnimationSamplerInterpolation { unAnimationSamplerInterpolation :: Text }+  deriving (Eq, Ord, Show, FromJSON, ToJSON, Generic)++pattern LINEAR :: AnimationSamplerInterpolation+pattern LINEAR = AnimationSamplerInterpolation "LINEAR"++pattern STEP :: AnimationSamplerInterpolation+pattern STEP = AnimationSamplerInterpolation "STEP"++pattern CUBICSPLINE :: AnimationSamplerInterpolation+pattern CUBICSPLINE = AnimationSamplerInterpolation "CUBICSPLINE"++-- | Targets an animation's sampler at a node's property.+data AnimationChannel = AnimationChannel+  { sampler    :: AnimationSamplerIx+  , target     :: AnimationChannelTarget+  , extensions :: Maybe Object+  , extras     :: Maybe Value+  } deriving (Eq, Show, Generic)++instance FromJSON AnimationChannel+instance ToJSON AnimationChannel++-- | The index of the node and TRS property that an animation channel targets.+data AnimationChannelTarget = AnimationChannelTarget+  { node       :: Maybe NodeIx+  , path       :: AnimationChannelTargetPath+  , extensions :: Maybe Object+  , extras     :: Maybe Value+  } deriving (Eq, Show, Generic)++instance FromJSON AnimationChannelTarget+instance ToJSON AnimationChannelTarget++-- | The name of the node's TRS property to modify, or the @weights@ of+-- the Morph Targets it instantiates.+-- For the @translation@ property, the values that are provided by+-- the sampler are the translation along the x, y, and z axes.+-- For the @rotation@ property, the values are a quaternion in+-- the order (x, y, z, w), where w is the scalar.+-- For the @scale@ property, the values are the scaling factors+-- along the x, y, and z axes.",+newtype AnimationChannelTargetPath = AnimationChannelTargetPath { unAnimationChannelTargetPath :: Text } -- XXX: T/R/S/weights/any+  deriving (Eq, Ord, Show, FromJSON, ToJSON, Generic)++pattern TRANSLATION :: AnimationChannelTargetPath+pattern TRANSLATION = AnimationChannelTargetPath "translation"++pattern ROTATION :: AnimationChannelTargetPath+pattern ROTATION = AnimationChannelTargetPath "rotation"++pattern SCALE :: AnimationChannelTargetPath+pattern SCALE = AnimationChannelTargetPath "scale"++pattern WEIGHTS :: AnimationChannelTargetPath+pattern WEIGHTS = AnimationChannelTargetPath "weights"
+ src/Codec/GlTF/Asset.hs view
@@ -0,0 +1,16 @@+module Codec.GlTF.Asset where++import Codec.GlTF.Prelude++-- | Metadata about the glTF asset.+data Asset = Asset+  { version    :: Text+  , copyright  :: Maybe Text+  , generator  :: Maybe Text+  , minVersion :: Maybe Text+  , extensions :: Maybe Object+  , extras     :: Maybe Value+  } deriving (Eq, Show, Generic)++instance FromJSON Asset+instance ToJSON Asset
+ src/Codec/GlTF/Buffer.hs view
@@ -0,0 +1,28 @@+module Codec.GlTF.Buffer+  ( BufferIx(..)+  , Buffer(..)+  ) where++import Codec.GlTF.Prelude++import Codec.GlTF.URI (URI)++newtype BufferIx = BufferIx { unBufferIx :: Int }+  deriving (Eq, Ord, Show, FromJSON, ToJSON, Generic)++-- | A buffer points to binary geometry, animation, or skins.+--+-- glTF Buffer referring to GLB-stored BIN chunk, must have @buffer.uri@+-- property undefined, and it must be the first element of buffers array;+-- byte length of BIN chunk could be up to 3 bytes bigger than JSON-defined+-- buffer.byteLength to satisfy GLB padding requirements.+data Buffer = Buffer+  { byteLength :: Size+  , uri        :: Maybe URI+  , name       :: Maybe Text+  , extensions :: Maybe Object+  , extras     :: Maybe Value+  } deriving (Eq, Show, Generic)++instance FromJSON Buffer+instance ToJSON Buffer
+ src/Codec/GlTF/BufferView.hs view
@@ -0,0 +1,53 @@+module Codec.GlTF.BufferView+  ( BufferViewIx(..)+  , BufferView(..)+  , BufferViewTarget(..)+  , pattern ARRAY_BUFFER+  , pattern ELEMENT_ARRAY_BUFFER+  ) where++import Codec.GlTF.Prelude++import Codec.GlTF.Buffer (BufferIx)++newtype BufferViewIx = BufferViewIx { unBufferViewIx :: Int }+  deriving (Eq, Ord, Show, FromJSON, ToJSON, Generic)++-- | A view into a buffer generally representing a subset of the buffer.+data BufferView = BufferView+  { buffer     :: BufferIx+  , byteOffset :: Size+  , byteLength :: Size+  , byteStride :: Maybe Size -- [4-252]+    -- ^ The stride, in bytes, between vertex attributes.+    -- When this is not defined, data is tightly packed.+    -- When two or more accessors use the same bufferView, this field must be defined.+  , target     :: Maybe BufferViewTarget+    -- ^ The target that the GPU buffer should be bound to.+  , name       :: Maybe Text+  , extensions :: Maybe Object+  , extras     :: Maybe Value+  } deriving (Eq, Show, Generic)++instance FromJSON BufferView where+  parseJSON = withObject "BufferView" \o -> do+    buffer     <- o .:  "buffer"+    byteOffset <- o .:? "byteOffset" .!= 0+    byteLength <- o .:  "byteLength"+    byteStride <- o .:? "byteStride"+    target     <- o .:? "target"+    name       <- o .:? "name"+    extensions <- o .:? "extensions"+    extras     <- o .:? "extras"+    pure BufferView{..}++instance ToJSON BufferView++newtype BufferViewTarget = BufferViewTarget { unBufferViewTarget :: Int }+  deriving (Eq, Ord, Show, FromJSON, ToJSON, Generic)++pattern ARRAY_BUFFER :: BufferViewTarget+pattern ARRAY_BUFFER = BufferViewTarget 34962++pattern ELEMENT_ARRAY_BUFFER :: BufferViewTarget+pattern ELEMENT_ARRAY_BUFFER = BufferViewTarget 34963
+ src/Codec/GlTF/Camera.hs view
@@ -0,0 +1,68 @@+module Codec.GlTF.Camera+  ( CameraIx(..)+  , Camera(..)+  , CameraType(..)+  , pattern PERSPECTIVE+  , pattern ORTHOGRAPHIC++  , CameraPerspective(..)+  , CameraOrthographic(..)+  ) where++import Codec.GlTF.Prelude++newtype CameraIx = CameraIx { unCameraIx :: Int }+  deriving (Eq, Ord, Show, FromJSON, ToJSON, Generic)++-- | A camera's projection.+--+-- A node can reference a camera to apply a transform to place the camera in the scene.+data Camera = Camera+  { type'        :: CameraType+  , perspective  :: Maybe CameraPerspective+  , orthographic :: Maybe CameraOrthographic+  , name         :: Maybe Text+  , extensions   :: Maybe Object+  , extras       :: Maybe Value+  } deriving (Eq, Show, Generic)++instance FromJSON Camera where+  parseJSON = gParseJSON++instance ToJSON Camera where+  toJSON = gToJSON++newtype CameraType = CameraType { unCameraType :: Text }+  deriving (Eq, Ord, Show, FromJSON, ToJSON, Generic)++pattern PERSPECTIVE :: CameraType+pattern PERSPECTIVE = CameraType "perspective"++pattern ORTHOGRAPHIC :: CameraType+pattern ORTHOGRAPHIC = CameraType "orthographic"++-- | A perspective camera containing properties to create a perspective projection matrix.+data CameraPerspective = CameraPerspective+  { yfov        :: Float+  , znear       :: Float+  , aspectRatio :: Maybe Float+  , zfar        :: Maybe Float+  , extensions  :: Maybe Object+  , extras      :: Maybe Value+  } deriving (Eq, Show, Generic)++instance FromJSON CameraPerspective+instance ToJSON CameraPerspective++-- | An orthographic camera containing properties to create an orthographic projection matrix.+data CameraOrthographic = CameraOrthographic+  { xmag         :: Float+  , ymag         :: Float+  , zfar         :: Float+  , znear        :: Float+  , extensions   :: Maybe Object+  , extras       :: Maybe Value+  } deriving (Eq, Show, Generic)++instance FromJSON CameraOrthographic+instance ToJSON CameraOrthographic
+ src/Codec/GlTF/Image.hs view
@@ -0,0 +1,28 @@+module Codec.GlTF.Image+  ( ImageIx(..)+  , Image(..)+  ) where++import Codec.GlTF.Prelude++import Codec.GlTF.BufferView (BufferViewIx)+import Codec.GlTF.URI (URI)++newtype ImageIx = ImageIx { unImageIx :: Int }+  deriving (Eq, Ord, Show, FromJSON, ToJSON, Generic)++-- | Image data used to create a texture.+--+-- Image can be referenced by URI or bufferView index.+-- @mimeType@ is required in the latter case.+data Image = Image+  { uri        :: Maybe URI+  , mimeType   :: Maybe Text+  , bufferView :: Maybe BufferViewIx+  , name       :: Maybe Text+  , extensions :: Maybe Object+  , extras     :: Maybe Value+  } deriving (Eq, Show, Generic)++instance FromJSON Image+instance ToJSON Image
+ src/Codec/GlTF/Material.hs view
@@ -0,0 +1,91 @@+module Codec.GlTF.Material+  ( MaterialIx(..)+  , Material(..)+  , MaterialAlphaMode(..)+  , pattern OPAQUE+  , pattern MASK+  , pattern BLEND+  , MaterialNormal(..)+  , MaterialOcclusion(..)+  ) where++import Codec.GlTF.Prelude++import Codec.GlTF.PbrMetallicRoughness (PbrMetallicRoughness)+import Codec.GlTF.TextureInfo (TextureInfo, TextureInfo_)++newtype MaterialIx = MaterialIx { unMaterialIx :: Int }+  deriving (Eq, Ord, Show, FromJSON, ToJSON, Generic)++-- | The material appearance of a primitive.+data Material = Material+  { emissiveFactor :: (Float, Float, Float)+  , alphaMode      :: MaterialAlphaMode+  , alphaCutoff    :: Float+  , doubleSided    :: Bool++  , pbrMetallicRoughness :: Maybe PbrMetallicRoughness+  , normalTexture        :: Maybe (TextureInfo MaterialNormal)+  , occlusionTexture     :: Maybe (TextureInfo MaterialOcclusion)+  , emissiveTexture      :: Maybe (TextureInfo_)++  , name         :: Maybe Text+  , extensions   :: Maybe Object+  , extras       :: Maybe Value+  } deriving (Eq, Show, Generic)++instance FromJSON Material where+  parseJSON = withObject "Material" \o -> do+    emissiveFactor       <- o .:? "emissiveFactor" .!= (0, 0, 0)+    alphaMode            <- o .:? "alphaMode"      .!= OPAQUE+    alphaCutoff          <- o .:? "alphaCutoff"    .!= 0.5+    doubleSided          <- o .:? "doubleSided"    .!= False++    pbrMetallicRoughness <- o .:? "pbrMetallicRoughness"+    normalTexture        <- o .:? "normalTexture"+    occlusionTexture     <- o .:? "occlusionTexture"+    emissiveTexture      <- o .:? "emissiveTexture"++    name                 <- o .:? "name"+    extensions           <- o .:? "extensions"+    extras               <- o .:? "extras"+    pure Material{..}++instance ToJSON Material++-- | The alpha rendering mode of the material.+newtype MaterialAlphaMode = MaterialAlphaMode { unMaterialAlphaMode :: Text }+  deriving (Eq, Ord, Show, FromJSON, ToJSON, Generic)++pattern OPAQUE :: MaterialAlphaMode+pattern OPAQUE = MaterialAlphaMode "OPAQUE"++pattern MASK :: MaterialAlphaMode+pattern MASK = MaterialAlphaMode "MASK"++pattern BLEND :: MaterialAlphaMode+pattern BLEND = MaterialAlphaMode "BLEND"++data MaterialNormal = MaterialNormal+  { scale :: Float+    -- ^ The scalar multiplier applied to each normal vector of the normal texture.+  } deriving (Eq, Show, Generic)++instance FromJSON MaterialNormal where+  parseJSON = withObject "MaterialNormal" \o -> do+    scale <- o .:? "scale" .!= 1.0+    pure MaterialNormal{..}++instance ToJSON MaterialNormal++data MaterialOcclusion = MaterialOcclusion+  { strength :: Float+    -- ^ A scalar multiplier controlling the amount of occlusion applied. @[0.0-1.0]@+  } deriving (Eq, Show, Generic)++instance FromJSON MaterialOcclusion where+  parseJSON = withObject "MaterialOcclusion" \o -> do+    strength <- o .:? "strength" .!= 1.0+    pure MaterialOcclusion{..}++instance ToJSON MaterialOcclusion
+ src/Codec/GlTF/Mesh.hs view
@@ -0,0 +1,93 @@+module Codec.GlTF.Mesh+  ( MeshIx(..)+  , Mesh(..)++  , MeshPrimitive(..)+  , MeshPrimitiveMode(..)+  , pattern POINTS+  , pattern LINES+  , pattern LINE_LOOP+  , pattern LINE_STRIP+  , pattern TRIANGLES+  , pattern TRIANGLE_STRIP+  , pattern TRIANGLE_FAN+ ) where++import Codec.GlTF.Prelude++import Codec.GlTF.Accessor (AccessorIx)+import Codec.GlTF.Material (MaterialIx)++newtype MeshIx = MeshIx { unMeshIx :: Int }+  deriving (Eq, Ord, Show, FromJSON, ToJSON, Generic)++-- | A set of primitives to be rendered.+--+-- A node can contain one mesh. A node's transform places the mesh in the scene.+data Mesh = Mesh+  { primitives :: Vector MeshPrimitive+  , weights    :: Maybe (Vector Float)+  , name       :: Maybe Text+  , extensions :: Maybe Object+  , extras     :: Maybe Value+  } deriving (Eq, Show, Generic)++instance FromJSON Mesh where+  parseJSON = withObject "Mesh" \o -> do+    primitives <- o .:  "primitives"+    weights    <- o .:? "weights"+    name       <- o .:? "name"+    extensions <- o .:? "extensions"+    extras     <- o .:? "extras"+    pure Mesh{..}++instance ToJSON Mesh++-- | Geometry to be rendered with the given material.+data MeshPrimitive = MeshPrimitive+  { attributes   :: HashMap Text AccessorIx+  , mode         :: MeshPrimitiveMode+  , indices      :: Maybe AccessorIx+  , material     :: Maybe MaterialIx+  , targets      :: Maybe (Vector (HashMap Text AccessorIx))+  , extensions   :: Maybe Object+  , extras       :: Maybe Value+  } deriving (Eq, Show, Generic)++instance FromJSON MeshPrimitive where+  parseJSON = withObject "MeshPrimitive" \o -> do+    attributes <- o .:  "attributes"+    mode       <- o .:? "mode" .!= TRIANGLES+    indices    <- o .:? "indices"+    material   <- o .:? "material"+    targets    <- o .:? "targets"+    extensions <- o .:? "extensions"+    extras     <- o .:? "extras"+    pure MeshPrimitive{..}++instance ToJSON MeshPrimitive++-- | The type of primitives to render.+newtype MeshPrimitiveMode = MeshPrimitiveMode { unMeshPrimitiveMode :: Int }+  deriving (Eq, Ord, Show, FromJSON, ToJSON, Generic)++pattern POINTS :: MeshPrimitiveMode+pattern POINTS = MeshPrimitiveMode 0++pattern LINES :: MeshPrimitiveMode+pattern LINES = MeshPrimitiveMode 1++pattern LINE_LOOP :: MeshPrimitiveMode+pattern LINE_LOOP = MeshPrimitiveMode 2++pattern LINE_STRIP :: MeshPrimitiveMode+pattern LINE_STRIP = MeshPrimitiveMode 3++pattern TRIANGLES :: MeshPrimitiveMode+pattern TRIANGLES = MeshPrimitiveMode 4++pattern TRIANGLE_STRIP :: MeshPrimitiveMode+pattern TRIANGLE_STRIP = MeshPrimitiveMode 5++pattern TRIANGLE_FAN :: MeshPrimitiveMode+pattern TRIANGLE_FAN = MeshPrimitiveMode 6
+ src/Codec/GlTF/Node.hs view
@@ -0,0 +1,73 @@+module Codec.GlTF.Node+  ( NodeIx(..)+  , Node(..)+  , NodeMatrix(..)++    -- XXX: Misplaced here due to mutual recursion.+  , SkinIx(..)+  , Skin(..)+  ) where++import Codec.GlTF.Prelude++import Codec.GlTF.Accessor (AccessorIx)+import Codec.GlTF.Camera (CameraIx)+import Codec.GlTF.Mesh (MeshIx)++newtype NodeIx = NodeIx { unNodeIx :: Int }+  deriving (Eq, Ord, Show, FromJSON, ToJSON, Generic)++-- | A node in the node hierarchy.+--+-- When the node contains skin, all mesh.primitives must contain JOINTS_0 and WEIGHTS_0 attributes.+--+-- A node can have either a matrix or any combination of translation/rotation/scale (TRS) properties.+--+-- TRS properties are converted to matrices and postmultiplied in the T * R * S order to+-- compose the transformation matrix; first the scale is applied to the vertices, then+-- the rotation, and then the translation.+-- If none are provided, the transform is the identity.+--+-- When a node is targeted for animation (referenced by an animation.channel.target),+-- only TRS properties may be present; matrix will not be present.+data Node = Node+  { camera :: Maybe CameraIx+  , children    :: Maybe (Vector NodeIx)+  , skin        :: Maybe SkinIx+  , matrix      :: Maybe NodeMatrix+  , mesh        :: Maybe MeshIx+  , rotation    :: Maybe (Float, Float, Float, Float)+  , scale       :: Maybe (Float, Float, Float)+  , translation :: Maybe (Float, Float, Float)+  , weights     :: Maybe (Vector Float)+  , name        :: Maybe Text+  , extensions  :: Maybe Object+  , extras      :: Maybe Value+  } deriving (Eq, Show, Generic)++instance FromJSON Node+instance ToJSON Node++-- | A floating-point 4x4 transformation matrix stored in column-major order.+newtype NodeMatrix = NodeMatrix { unNodeMatrix :: Vector Float }+  deriving (Eq, Ord, Show, FromJSON, ToJSON, Generic)++newtype SkinIx = SkinIx { unSkinIx :: Int }+  deriving (Eq, Ord, Show, FromJSON, ToJSON, Generic)++-- | Joints and matrices defining a skin.+data Skin = Skin+  { joints              :: Vector (NodeIx)+  , skeleton            :: Maybe NodeIx+  , inverseBindMatrices :: Maybe AccessorIx+    -- ^ The index of the accessor containing the floating-point+    -- 4x4 inverse-bind matrices.+    -- The default is that each matrix is a 4x4 identity matrix,+    -- which implies that inverse-bind matrices were pre-applied.+  , name                :: Maybe Text+  , extensions          :: Maybe Object+  , extras              :: Maybe Value+  } deriving (Eq, Show, Generic)++instance FromJSON Skin+instance ToJSON Skin
+ src/Codec/GlTF/PbrMetallicRoughness.hs view
@@ -0,0 +1,34 @@+module Codec.GlTF.PbrMetallicRoughness+  ( PbrMetallicRoughness(..)+  ) where++import Codec.GlTF.Prelude++import Codec.GlTF.TextureInfo (TextureInfo_)++-- | A set of parameter values that are used to define the metallic-roughness+-- material model from Physically-Based Rendering (PBR) methodology.+data PbrMetallicRoughness = PbrMetallicRoughness+  { baseColorFactor          :: (Float, Float, Float, Float)+  , metallicFactor           :: Float+  , roughnessFactor          :: Float+  , metallicRoughnessTexture :: Maybe TextureInfo_+  , baseColorTexture         :: Maybe TextureInfo_+  , extensions               :: Maybe Object+  , extras                   :: Maybe Value+  } deriving (Eq, Show, Generic)++instance FromJSON PbrMetallicRoughness where+  parseJSON = withObject "PbrMetallicRoughness" \o -> do+    baseColorFactor          <- o .:? "baseColorFactor" .!= (1.0, 1.0, 1.0, 1.0)+    metallicFactor           <- o .:? "metallicFactor"  .!= 1.0+    roughnessFactor          <- o .:? "roughnessFactor" .!= 1.0++    metallicRoughnessTexture <- o .:? "metallicRoughnessTexture"+    baseColorTexture         <- o .:? "baseColorTexture"++    extensions               <- o .:? "extensions"+    extras                   <- o .:? "extras"+    pure PbrMetallicRoughness{..}++instance ToJSON PbrMetallicRoughness
+ src/Codec/GlTF/Prelude.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE PartialTypeSignatures #-}++{-# OPTIONS_GHC -Wno-partial-type-signatures #-}++module Codec.GlTF.Prelude+  ( Size++  , FromJSON(..)+  , ToJSON(..)+  , Generic+  , gParseJSON+  , gToJSON++  , HashMap+  , Object+  , Scientific+  , Text+  , Value+  , Vector++  , withText+  , withObject+  , (.:)+  , (.:?)+  , (.!=)+  ) where++import Data.Aeson (FromJSON(..), ToJSON(..), Value, Object, withText, withObject, (.:), (.:?), (.!=))+import Data.Aeson.Types (Parser, Options(..), defaultOptions, genericParseJSON, genericToJSON)+import Data.List (dropWhileEnd)+import Data.Scientific (Scientific)+import Data.Text (Text)+import Data.Vector (Vector)+import Data.HashMap.Strict (HashMap)+import GHC.Generics (Generic)++type Size = Int++gParseJSON :: _ => Value -> Parser a+gParseJSON = genericParseJSON dropEndTick++gToJSON :: _ => a -> Value+gToJSON = genericToJSON dropEndTick++dropEndTick :: Options+dropEndTick = defaultOptions+  { fieldLabelModifier = dropWhileEnd (== '\'')+  }
+ src/Codec/GlTF/Root.hs view
@@ -0,0 +1,43 @@+module Codec.GlTF.Root where++import Codec.GlTF.Prelude++import Codec.GlTF.Asset (Asset)+import Codec.GlTF.Accessor (Accessor)+import Codec.GlTF.Animation (Animation)+import Codec.GlTF.Buffer (Buffer)+import Codec.GlTF.BufferView (BufferView)+import Codec.GlTF.Camera (Camera)+import Codec.GlTF.Image (Image)+import Codec.GlTF.Material (Material)+import Codec.GlTF.Mesh (Mesh)+import Codec.GlTF.Node (Node)+import Codec.GlTF.Sampler (Sampler)+import Codec.GlTF.Scene (Scene)+import Codec.GlTF.Skin (Skin)+import Codec.GlTF.Texture (Texture)++-- | The root object for a glTF asset.+data GlTF = GlTF+  { asset              :: Asset+  , extensionsUsed     :: Maybe (Vector Text)+  , extensionsRequired :: Maybe (Vector Text)+  , accessors          :: Maybe (Vector Accessor)+  , animations         :: Maybe (Vector Animation)+  , buffers            :: Maybe (Vector Buffer)+  , bufferViews        :: Maybe (Vector BufferView)+  , cameras            :: Maybe (Vector Camera)+  , images             :: Maybe (Vector Image)+  , materials          :: Maybe (Vector Material)+  , meshes             :: Maybe (Vector Mesh)+  , nodes              :: Maybe (Vector Node)+  , samplers           :: Maybe (Vector Sampler)+  , scenes             :: Maybe (Vector Scene)+  , skins              :: Maybe (Vector Skin)+  , textures           :: Maybe (Vector Texture)+  , extensions         :: Maybe Object+  , extras             :: Maybe Value+  } deriving (Eq, Show, Generic)++instance FromJSON GlTF+instance ToJSON GlTF
+ src/Codec/GlTF/Sampler.hs view
@@ -0,0 +1,102 @@+module Codec.GlTF.Sampler+  ( SamplerIx(..)+  , Sampler(..)++  , SamplerWrap(..)+  , pattern CLAMP_TO_EDGE+  , pattern MIRRORED_REPEAT+  , pattern REPEAT++  , SamplerMagFilter(..)+  , pattern MAG_NEAREST+  , pattern MAG_LINEAR++  , SamplerMinFilter(..)+  , pattern MIN_NEAREST+  , pattern MIN_LINEAR+  , pattern MIN_NEAREST_MIPMAP_NEAREST+  , pattern MIN_LINEAR_MIPMAP_NEAREST+  , pattern MIN_NEAREST_MIPMAP_LINEAR+  , pattern MIN_LINEAR_MIPMAP_LINEAR+  ) where++import Codec.GlTF.Prelude++newtype SamplerIx = SamplerIx { unSamplerIx :: Int }+  deriving (Eq, Ord, Show, FromJSON, ToJSON, Generic)++-- | The root object for a glTF Sampler.+data Sampler = Sampler+  { wrapS      :: SamplerWrap+  , wrapT      :: SamplerWrap+  , magFilter  :: Maybe SamplerMagFilter+  , minFilter  :: Maybe SamplerMinFilter+  , name       :: Maybe Text+  , extensions :: Maybe Object+  , extras     :: Maybe Value+  } deriving (Eq, Show, Generic)++instance FromJSON Sampler where+  parseJSON = withObject "Sampler" \o -> do+    wrapS      <- o .:? "wrapS" .!= REPEAT+    wrapT      <- o .:? "wrapT" .!= REPEAT+    magFilter  <- o .:? "magFilter"+    minFilter  <- o .:? "minFilter"+    name       <- o .:? "name"+    extensions <- o .:? "extensions"+    extras     <- o .:? "extras"+    pure Sampler{..}++instance ToJSON Sampler where+  toJSON = gToJSON++-- | Wrapping mode.+--+-- All valid values correspond to WebGL enums.+newtype SamplerWrap = SamplerWrap { unSamplerWrap :: Int }+  deriving (Eq, Ord, Show, FromJSON, ToJSON, Generic)++pattern CLAMP_TO_EDGE :: SamplerWrap+pattern CLAMP_TO_EDGE = SamplerWrap 33071++pattern MIRRORED_REPEAT :: SamplerWrap+pattern MIRRORED_REPEAT = SamplerWrap 33648++pattern REPEAT :: SamplerWrap+pattern REPEAT = SamplerWrap 10497++-- | Magnification filter.+--+-- Valid values correspond to WebGL enums.+newtype SamplerMagFilter = SamplerMagFilter { unSamplerMagFilter :: Int }+  deriving (Eq, Ord, Show, FromJSON, ToJSON, Generic)++pattern MAG_NEAREST :: SamplerMagFilter+pattern MAG_NEAREST = SamplerMagFilter 9728++pattern MAG_LINEAR :: SamplerMagFilter+pattern MAG_LINEAR = SamplerMagFilter 9729++-- | Minification filter.+--+-- All valid values correspond to WebGL enums.+newtype SamplerMinFilter = SamplerMinFilter { unSamplerMinFilter :: Int }+  deriving (Eq, Ord, Show, FromJSON, ToJSON, Generic)++pattern MIN_NEAREST :: SamplerMinFilter+pattern MIN_NEAREST = SamplerMinFilter 9728++pattern MIN_LINEAR :: SamplerMinFilter+pattern MIN_LINEAR = SamplerMinFilter 9729++pattern MIN_NEAREST_MIPMAP_NEAREST :: SamplerMinFilter+pattern MIN_NEAREST_MIPMAP_NEAREST = SamplerMinFilter 9984++pattern MIN_LINEAR_MIPMAP_NEAREST :: SamplerMinFilter+pattern MIN_LINEAR_MIPMAP_NEAREST = SamplerMinFilter 9985++pattern MIN_NEAREST_MIPMAP_LINEAR :: SamplerMinFilter+pattern MIN_NEAREST_MIPMAP_LINEAR = SamplerMinFilter 9986++pattern MIN_LINEAR_MIPMAP_LINEAR :: SamplerMinFilter+pattern MIN_LINEAR_MIPMAP_LINEAR = SamplerMinFilter 9987
+ src/Codec/GlTF/Scene.hs view
@@ -0,0 +1,21 @@+module Codec.GlTF.Scene+  ( SceneIx(..)+  , Scene(..)+  ) where++import Codec.GlTF.Prelude++import Codec.GlTF.Node (NodeIx)++newtype SceneIx = SceneIx { unSceneIx :: Int }+  deriving (Eq, Ord, Show, FromJSON, ToJSON, Generic)++data Scene = Scene+  { nodes       :: Maybe (Vector NodeIx)+  , name        :: Maybe Text+  , extensions  :: Maybe Object+  , extras      :: Maybe Value+  } deriving (Eq, Show, Generic)++instance FromJSON Scene+instance ToJSON Scene
+ src/Codec/GlTF/Skin.hs view
@@ -0,0 +1,8 @@+-- XXX: Misplaced here due to mutual recursion.++module Codec.GlTF.Skin+  ( SkinIx(..)+  , Skin(..)+  ) where++import Codec.GlTF.Node (SkinIx(..), Skin(..))
+ src/Codec/GlTF/Texture.hs view
@@ -0,0 +1,23 @@+module Codec.GlTF.Texture+  ( TextureIx(..)+  , Texture(..)+  ) where++import Codec.GlTF.Prelude++import Codec.GlTF.Image (ImageIx)+import Codec.GlTF.Sampler (SamplerIx)++newtype TextureIx = TextureIx { unTextureIx :: Int }+  deriving (Eq, Ord, Show, FromJSON, ToJSON, Generic)++data Texture = Texture+  { sampler    :: Maybe SamplerIx+  , source     :: Maybe ImageIx+  , name       :: Maybe Text+  , extensions :: Maybe Object+  , extras     :: Maybe Value+  } deriving (Eq, Show, Generic)++instance FromJSON Texture+instance ToJSON Texture
+ src/Codec/GlTF/TextureInfo.hs view
@@ -0,0 +1,65 @@+module Codec.GlTF.TextureInfo+  ( TextureInfo(..)+  , TextureInfo_+  , Basic(..)+  ) where++import Codec.GlTF.Prelude++import Data.Foldable (toList)+import Data.Aeson+import qualified Data.HashMap.Strict as HashMap++-- | Reference to a texture.+data TextureInfo a = TextureInfo+  { index      :: Int+  , texCoord   :: Int+    -- ^ This integer value is used to construct a string+    -- in the format @TEXCOORD_<set index>@ which is a reference+    -- to a key in @mesh.primitives.attributes@+    -- (e.g. A value of 0 corresponds to @TEXCOORD_0@).+    --+    -- Mesh must have corresponding texture coordinate attributes+    -- for the material to be applicable to it.++  , subtype    :: a++  , extensions :: Maybe Object+  , extras     :: Maybe Value+  } deriving (Eq, Show, Generic)++instance (FromJSON a) => FromJSON (TextureInfo a) where+  parseJSON = withObject "TextureInfo" \o -> do+    index      <- o .:? "extensions" .!= 0+    texCoord   <- o .:? "extras"     .!= 0+    subtype    <- parseJSON (Object o)+    extensions <- o .:? "extensions"+    extras     <- o .:? "extras"+    pure TextureInfo{..}++instance (ToJSON a) => ToJSON (TextureInfo a) where+  toJSON TextureInfo{..} = object $ mconcat+    [ [ "index" .= index, "texCoord" .= texCoord]+    , case toJSON subtype of+        Null ->+          []+        Object sub ->+          HashMap.toList sub+        _ ->+          error "assert: subtype of TextureInfo encodes to Object"+    , [ "extensions" .= extensions' | extensions' <- toList extensions ]+    , [ "extras" .= extras' | extras' <- toList extras ]+    ]++-- | "TextureInfo" without extra fields.+type TextureInfo_ = TextureInfo Basic++-- | Placeholder for "TextureInfo" objects without extra fields.+data Basic = Basic+  deriving (Eq, Ord, Show, Generic)++instance FromJSON Basic where+  parseJSON _value = pure Basic++instance ToJSON Basic where+  toJSON Basic = Null
+ src/Codec/GlTF/URI.hs view
@@ -0,0 +1,33 @@+module Codec.GlTF.URI+  ( URI(..)+  , loadURI+  ) where++import Codec.GlTF.Prelude++import Data.ByteString (ByteString)+import Data.Text.Encoding (encodeUtf8)+import GHC.Stack (HasCallStack)++import qualified Data.ByteString.Base64 as Base64+import qualified Data.Text as Text++-- | The URI of the buffer or image.+--+-- Relative paths are relative to the .gltf file.+-- Instead of referencing an external file, the uri can also be a data-uri.+newtype URI = URI Text+  deriving (Eq, Ord, Show, FromJSON, ToJSON, Generic)++loadURI :: HasCallStack => (FilePath -> IO (Either String ByteString)) -> URI -> IO (Either String ByteString)+loadURI fileLoader (URI uri) =+  if Text.isPrefixOf "data:" uri then+    case Text.breakOn needle uri of+      (_prefix, "") ->+        error "Malformed data: URI"+      (_prefix, found) ->+        pure . Base64.decode . encodeUtf8 $ Text.drop (Text.length needle) found+  else+    fileLoader (Text.unpack uri)+  where+    needle = ";base64,"
+ test/Spec.hs view
@@ -0,0 +1,88 @@+module Main where++import Control.Monad (guard)+import Data.Foldable (toList)+import Data.List (isSuffixOf)+import Debug.Trace (traceM)+import Shower (printer)+import System.Directory (listDirectory)+import System.FilePath ((</>))++import qualified Data.ByteString as ByteString++import qualified Codec.GLB as GLB+import qualified Codec.GlTF as GlTF+import qualified Codec.GlTF.Buffer as Buffer+import qualified Codec.GlTF.Image as Image+import qualified Codec.GlTF.Root as Root+import qualified Codec.GlTF.URI as URI++assetsPath :: FilePath+assetsPath = ".." </> "assets"++main :: IO ()+main = do+  assets <- listDirectory assetsPath++  mapM_ testGltf do+    fp <- assets+    guard $ ".gltf" `isSuffixOf` fp+    pure $ assetsPath </> fp++  mapM_ testGlb do+    fp <- assets+    guard $ ".glb" `isSuffixOf` fp+    pure $ assetsPath </> fp++testGltf :: FilePath -> IO ()+testGltf source =+  GlTF.fromFile source >>= \case+    Left err -> do+      traceM err+      fail $ "gltf load error in " <> source+    Right gltf -> do+      printer gltf+      testBuffers source gltf++testGlb :: FilePath -> IO ()+testGlb source =+  GLB.fromFile source >>= \case+    Left (offset, err) -> do+      traceM err+      fail $ "glb error at " <> show offset+    Right glb -> do+      printer+        ( GLB.header glb+        , fmap (\GLB.Chunk{..} -> (chunkLength, chunkType)) (GLB.chunks glb)+        )+      case GlTF.fromChunk (head . toList $ GLB.chunks glb) of+        Left err -> do+          traceM err+          fail $ "glb json error inside " <> source+        Right gltf ->+          printer gltf++testBuffers :: FilePath -> Root.GlTF -> IO ()+testBuffers source gltf = do+  case Root.buffers gltf of+    Nothing ->+      pure ()+    Just buffers ->+      mapM_ (testURI source) $ concatMap (toList . Buffer.uri) buffers++  case Root.images gltf of+    Nothing ->+      pure ()+    Just images ->+      mapM_ (testURI source) $ concatMap (toList . Image.uri) images++testURI :: FilePath -> URI.URI -> IO ()+testURI _source uri = do+  URI.loadURI testLoader uri >>= \case+    Left err ->+      fail err+    Right bs ->+      printer (uri, ByteString.length bs)+  where+    testLoader path =+      fmap Right $ ByteString.readFile (assetsPath </> path)