gltf-loader (empty) → 0.1.0.0
raw patch · 20 files changed
+1701/−0 lines, 20 filesdep +basedep +base64dep +binarysetup-changed
Dependencies added: base, base64, binary, bytestring, gltf-codec, gltf-loader, hspec, linear, microlens, optparse-simple, rio, unordered-containers
Files
- LICENSE +17/−0
- README.md +85/−0
- Setup.hs +2/−0
- app/Command/GLTF/Loader.hs +7/−0
- app/Command/GLTF/Loader/App.hs +39/−0
- app/Command/GLTF/Loader/Run.hs +67/−0
- app/Main.hs +54/−0
- data/cube.gltf +117/−0
- data/invalid.gltf +1/−0
- gltf-loader.cabal +212/−0
- src/Text/GLTF/Loader.hs +39/−0
- src/Text/GLTF/Loader/Adapter.hs +108/−0
- src/Text/GLTF/Loader/BufferAccessor.hs +236/−0
- src/Text/GLTF/Loader/Errors.hs +28/−0
- src/Text/GLTF/Loader/Gltf.hs +157/−0
- test/Spec.hs +1/−0
- test/Text/GLTF/Loader/AdapterSpec.hs +167/−0
- test/Text/GLTF/Loader/BufferAccessorSpec.hs +94/−0
- test/Text/GLTF/Loader/Test/MkGltf.hs +177/−0
- test/Text/GLTF/LoaderSpec.hs +93/−0
+ LICENSE view
@@ -0,0 +1,17 @@+Copyright 2022 Sean Gillespie++Permission is hereby granted, free of charge, to any person obtaining a copy of this+software and associated documentation files (the "Software"), to deal in the Software+without restriction, including without limitation the rights to use, copy, modify, merge,+publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons+to whom the Software is furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all copies or+substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED,+INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR+PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE+FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR+OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER+DEALINGS IN THE SOFTWARE.
+ README.md view
@@ -0,0 +1,85 @@+# Haskell GlTF Loader++[](https://gitlab.com/sgillespie/haskell-gltf-loader/-/commits/main)++> A high level GlTF loader+++## Prerequisites++In order to build or install you will need++ * [GHC](https://www.haskell.org/downloads/) (Tested on 9.0.2)+ * [Stack](https://docs.haskellstack.org/en/stable/install_and_upgrade/) (Tested on 2.7.5)++## Building++Build the project++ stack setup+ stack build++Run the tests (if desired)++```+stack test+```++## API Documentation+To build the documentation, run++ stack haddock++## API Examples+Use `fromFile` or `fromBytestring` to load a GlTF scene+++ import Text.GLTF.Loader (fromFile)++ -- ...+ -- Load a GLTF scene from a file+ loadGltfFile :: IO (Either Errors Gltf)+ loadGltfFile = fromFile "./cube.gltf"++Then you can, for example, get all the vertices:++ getVertices :: Gltf -> [V3 Float]+ getVertices gltf = concatMap getVertices' (gltf ^. _meshes)+ where getVertices' mesh = concatMap (^. _meshPrimitivePositions) (mesh ^. _meshPrimitives)++## CLI+This includes a CLI utility to inspect GlTF files++ gltf-loader --help++## Roadmap++Currently, only retreiving indices are supported, but we hope to support the majority of GlTF+features:++[] Animitions+[] Asset+[] Cameras+[] Images+[] Materials+[x] Meshes+ [x] Positions+ [x] Indices+ [] Normals+ [] Texture Coordinates+[] Node+[] Samplers+[] Skins++## Authors++Sean Gillespie <sean@mistersg.net>++## Acknowledgements++This project is largely based on [https://hackage.haskell.org/package/gltf-codec](gltf-codec) by +Alexander Bondarenko++## License+This project is licensed under the MIT License. See [LICENSE](LICENSE)+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Command/GLTF/Loader.hs view
@@ -0,0 +1,7 @@+module Command.GLTF.Loader+ ( module Command.GLTF.Loader.App,+ module Command.GLTF.Loader.Run+ ) where++import Command.GLTF.Loader.App+import Command.GLTF.Loader.Run
+ app/Command/GLTF/Loader/App.hs view
@@ -0,0 +1,39 @@+module Command.GLTF.Loader.App where++import RIO+import RIO.Process++-- | Command line arguments+data Options = Options+ { optionsVerbose :: !Bool,+ optionsFile :: FilePath+ }++-- | Application state+data App = App+ { appLogFunc :: !LogFunc,+ appProcessContext :: !ProcessContext,+ appOptions :: !Options+ }++class HasOptions env where+ optionsL :: Lens' env Options++instance HasLogFunc App where+ logFuncL = lens appLogFunc (\x y -> x { appLogFunc = y })++instance HasProcessContext App where+ processContextL = lens appProcessContext (\x y -> x { appProcessContext = y })++instance HasOptions App where+ optionsL = lens appOptions (\app opts -> app { appOptions = opts })++_optionsVerbose :: Lens' Options Bool+_optionsVerbose = lens+ optionsVerbose+ (\opts verbose -> opts { optionsVerbose = verbose })++_optionsFile :: Lens' Options FilePath+_optionsFile = lens+ optionsFile+ (\opts file -> opts { optionsFile = file })
+ app/Command/GLTF/Loader/Run.hs view
@@ -0,0 +1,67 @@+module Command.GLTF.Loader.Run (run) where++import Command.GLTF.Loader.App+import Text.GLTF.Loader++import Lens.Micro+import Linear (V3(..))+import RIO+import RIO.List (nub)++run :: RIO App ()+run = do+ file <- asks $ view (optionsL . _optionsFile)+ logInfo $ "File: " <> fromString file++ result <- liftIO $ fromFile file+ either reportError reportGltf result++reportError :: HasLogFunc logger => Errors -> RIO logger ()+reportError err+ = logError (display err)+ >> exitFailure++reportGltf :: Gltf -> RIO App ()+reportGltf gltf = do+ reportAsset $ gltf ^. _asset+ + logInfo "" -- Blank line++ reportNodes gltf++reportAsset :: Asset -> RIO App ()+reportAsset asset = do+ logInfo $ "Generator: " <> asset ^. _assetGenerator . to (fromMaybe "Unknown") . to display+ logInfo $ "Version: " <> asset ^. _assetVersion . to display++reportNodes :: Gltf -> RIO App ()+reportNodes gltf = do+ let nodes = gltf ^. _nodes+ logInfo $ "Nodes: " <> display (RIO.length nodes)++ forM_ nodes $ \node -> do+ logInfo $ " Name: " <> maybe "Unknown node" display (view _nodeName node)++ forM_ (node ^. _nodeMeshId) $ \meshId -> do+ logInfo " Mesh: "+ forM_ (gltf ^. _meshes ^? ix meshId) reportMesh+ ++reportMesh :: Mesh -> RIO App ()+reportMesh mesh = do+ logInfo $ " Name: " <> mesh ^. _meshName . to (display . fromMaybe "Unknown")+ logInfo " Mesh Primitives:"++ forM_ (mesh ^. _meshPrimitives) $ \primitive' -> do+ logInfo " Vertex Positions:"++ forM_ (nub $ primitive' ^. _meshPrimitivePositions) $ \position -> do+ logInfo $ " " <> displayV3 position+ +displayV3 :: Display a => V3 a -> Utf8Builder+displayV3 (V3 x y z)+ = "("+ <> display x <> ", "+ <> display y <> ", "+ <> display z <>+ ")"
+ app/Main.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE TemplateHaskell #-}+module Main (main) where++import Command.GLTF.Loader+import Paths_gltf_loader++import RIO+import RIO.Process+import Options.Applicative.Simple++main :: IO ()+main = do+ (options', _) <- parseOptions+ logOptions <- logOptionsHandle stderr (optionsVerbose options')+ processContext <- mkDefaultProcessContext++ runApp processContext options' logOptions run++parseOptions :: IO (Options, ())+parseOptions = simpleOptions version' header' description options empty+ where version' = $(simpleVersion version)+ header' = "Header for command line arguments"+ description = "A tool it inspect GlTF files"++runApp+ :: MonadUnliftIO m+ => ProcessContext+ -> Options+ -> LogOptions+ -> RIO App a+ -> m a+runApp processContext cliOptions logOptions appAction+ = withLogFunc logOptions $ \logFunc -> runRIO (mkApp logFunc) appAction+ where mkApp logFunc = App+ { appLogFunc = logFunc,+ appProcessContext = processContext,+ appOptions = cliOptions+ }++options :: Parser Options+options = Options <$> switch verboseOption <*> strArgument fileArg++verboseOption :: Mod FlagFields Bool+verboseOption+ = long "verbose"+ <> short 'v'+ <> help "Verbose output?"++fileArg :: Mod ArgumentFields FilePath+fileArg+ = metavar "file"+ <> help "Name of the GlTF file"+ <> completer (bashCompleter "file")
+ data/cube.gltf view
@@ -0,0 +1,117 @@+{+ "asset" : {+ "generator" : "Khronos glTF Blender I/O v3.2.40",+ "version" : "2.0"+ },+ "scene" : 0,+ "scenes" : [+ {+ "name" : "Scene",+ "nodes" : [+ 0+ ]+ }+ ],+ "nodes" : [+ {+ "mesh" : 0,+ "name" : "Cube"+ }+ ],+ "materials" : [+ {+ "doubleSided" : true,+ "name" : "Material",+ "pbrMetallicRoughness" : {+ "baseColorFactor" : [+ 0.800000011920929,+ 0.800000011920929,+ 0.800000011920929,+ 1+ ],+ "metallicFactor" : 0,+ "roughnessFactor" : 0.4000000059604645+ }+ }+ ],+ "meshes" : [+ {+ "name" : "Cube",+ "primitives" : [+ {+ "attributes" : {+ "POSITION" : 0,+ "NORMAL" : 1,+ "TEXCOORD_0" : 2+ },+ "indices" : 3,+ "material" : 0+ }+ ]+ }+ ],+ "accessors" : [+ {+ "bufferView" : 0,+ "componentType" : 5126,+ "count" : 24,+ "max" : [+ 1,+ 1,+ 1+ ],+ "min" : [+ -1,+ -1,+ -1+ ],+ "type" : "VEC3"+ },+ {+ "bufferView" : 1,+ "componentType" : 5126,+ "count" : 24,+ "type" : "VEC3"+ },+ {+ "bufferView" : 2,+ "componentType" : 5126,+ "count" : 24,+ "type" : "VEC2"+ },+ {+ "bufferView" : 3,+ "componentType" : 5123,+ "count" : 36,+ "type" : "SCALAR"+ }+ ],+ "bufferViews" : [+ {+ "buffer" : 0,+ "byteLength" : 288,+ "byteOffset" : 0+ },+ {+ "buffer" : 0,+ "byteLength" : 288,+ "byteOffset" : 288+ },+ {+ "buffer" : 0,+ "byteLength" : 192,+ "byteOffset" : 576+ },+ {+ "buffer" : 0,+ "byteLength" : 72,+ "byteOffset" : 768+ }+ ],+ "buffers" : [+ {+ "byteLength" : 840,+ "uri" : "data:application/octet-stream;base64,AACAPwAAgD8AAIC/AACAPwAAgD8AAIC/AACAPwAAgD8AAIC/AACAPwAAgL8AAIC/AACAPwAAgL8AAIC/AACAPwAAgL8AAIC/AACAPwAAgD8AAIA/AACAPwAAgD8AAIA/AACAPwAAgD8AAIA/AACAPwAAgL8AAIA/AACAPwAAgL8AAIA/AACAPwAAgL8AAIA/AACAvwAAgD8AAIC/AACAvwAAgD8AAIC/AACAvwAAgD8AAIC/AACAvwAAgL8AAIC/AACAvwAAgL8AAIC/AACAvwAAgL8AAIC/AACAvwAAgD8AAIA/AACAvwAAgD8AAIA/AACAvwAAgD8AAIA/AACAvwAAgL8AAIA/AACAvwAAgL8AAIA/AACAvwAAgL8AAIA/AAAAAAAAAAAAAIC/AAAAAAAAgD8AAACAAACAPwAAAAAAAACAAAAAAAAAgL8AAACAAAAAAAAAAAAAAIC/AACAPwAAAAAAAACAAAAAAAAAAAAAAIA/AAAAAAAAgD8AAACAAACAPwAAAAAAAACAAAAAAAAAgL8AAACAAAAAAAAAAAAAAIA/AACAPwAAAAAAAACAAACAvwAAAAAAAACAAAAAAAAAAAAAAIC/AAAAAAAAgD8AAACAAACAvwAAAAAAAACAAAAAAAAAgL8AAACAAAAAAAAAAAAAAIC/AACAvwAAAAAAAACAAAAAAAAAAAAAAIA/AAAAAAAAgD8AAACAAACAvwAAAAAAAACAAAAAAAAAgL8AAACAAAAAAAAAAAAAAIA/AAAgPwAAAD8AACA/AAAAPwAAID8AAAA/AADAPgAAAD8AAMA+AAAAPwAAwD4AAAA/AAAgPwAAgD4AACA/AACAPgAAID8AAIA+AADAPgAAgD4AAMA+AACAPgAAwD4AAIA+AAAgPwAAQD8AACA/AABAPwAAYD8AAAA/AADAPgAAQD8AAAA+AAAAPwAAwD4AAEA/AAAgPwAAgD8AACA/AAAAAAAAYD8AAIA+AADAPgAAgD8AAAA+AACAPgAAwD4AAAAAAQAOABQAAQAUAAcACgAGABMACgATABcAFQASAAwAFQAMAA8AEAADAAkAEAAJABYABQACAAgABQAIAAsAEQANAAAAEQAAAAQA"+ }+ ]+}
+ data/invalid.gltf view
@@ -0,0 +1,1 @@+ohea
+ gltf-loader.cabal view
@@ -0,0 +1,212 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.34.7.+--+-- see: https://github.com/sol/hpack++name: gltf-loader+version: 0.1.0.0+synopsis: High level GlTF loader+description: Please see the README on Github at <https://github.com/sgillespie/haskell-gltf-loader#readme>+category: Graphics+homepage: https://github.com/sgillespiep/haskell-gltf-loader#readme+bug-reports: https://github.com/sgillespiep/haskell-gltf-loader/issues+author: Sean D Gillespie+maintainer: sean@mistersg.net+copyright: 2022 Sean Gillespie+license: MIT+license-file: LICENSE+build-type: Simple+extra-source-files:+ README.md+ data/cube.gltf+ data/invalid.gltf++source-repository head+ type: git+ location: https://github.com/sgillespiep/haskell-gltf-loader++library+ exposed-modules:+ Text.GLTF.Loader+ Text.GLTF.Loader.Adapter+ Text.GLTF.Loader.BufferAccessor+ Text.GLTF.Loader.Errors+ Text.GLTF.Loader.Gltf+ other-modules:+ Paths_gltf_loader+ hs-source-dirs:+ src+ default-extensions:+ BangPatterns+ BinaryLiterals+ ConstraintKinds+ DataKinds+ DefaultSignatures+ DeriveDataTypeable+ DeriveFoldable+ DeriveFunctor+ DeriveGeneric+ DeriveTraversable+ DoAndIfThenElse+ EmptyDataDecls+ ExistentialQuantification+ FlexibleContexts+ FlexibleInstances+ FunctionalDependencies+ GADTs+ GeneralizedNewtypeDeriving+ InstanceSigs+ KindSignatures+ LambdaCase+ MultiParamTypeClasses+ MultiWayIf+ NamedFieldPuns+ NoImplicitPrelude+ OverloadedStrings+ OverloadedLists+ PartialTypeSignatures+ PatternGuards+ PolyKinds+ RankNTypes+ RecordWildCards+ ScopedTypeVariables+ StandaloneDeriving+ TupleSections+ TypeFamilies+ TypeSynonymInstances+ ViewPatterns+ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints+ build-depends:+ base >=4.11 && <10+ , binary+ , bytestring+ , gltf-codec+ , linear+ , microlens+ , rio >=0.1.12.0+ , unordered-containers+ default-language: Haskell2010++executable gltf-loader-exe+ main-is: Main.hs+ other-modules:+ Command.GLTF.Loader+ Command.GLTF.Loader.App+ Command.GLTF.Loader.Run+ Paths_gltf_loader+ hs-source-dirs:+ app+ default-extensions:+ BangPatterns+ BinaryLiterals+ ConstraintKinds+ DataKinds+ DefaultSignatures+ DeriveDataTypeable+ DeriveFoldable+ DeriveFunctor+ DeriveGeneric+ DeriveTraversable+ DoAndIfThenElse+ EmptyDataDecls+ ExistentialQuantification+ FlexibleContexts+ FlexibleInstances+ FunctionalDependencies+ GADTs+ GeneralizedNewtypeDeriving+ InstanceSigs+ KindSignatures+ LambdaCase+ MultiParamTypeClasses+ MultiWayIf+ NamedFieldPuns+ NoImplicitPrelude+ OverloadedStrings+ OverloadedLists+ PartialTypeSignatures+ PatternGuards+ PolyKinds+ RankNTypes+ RecordWildCards+ ScopedTypeVariables+ StandaloneDeriving+ TupleSections+ TypeFamilies+ TypeSynonymInstances+ ViewPatterns+ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ base >=4.11 && <10+ , gltf-loader+ , linear+ , microlens+ , optparse-simple+ , rio >=0.1.12.0+ default-language: Haskell2010++test-suite gltf-loader-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ Text.GLTF.Loader.AdapterSpec+ Text.GLTF.Loader.BufferAccessorSpec+ Text.GLTF.Loader.Test.MkGltf+ Text.GLTF.LoaderSpec+ Paths_gltf_loader+ hs-source-dirs:+ test+ default-extensions:+ BangPatterns+ BinaryLiterals+ ConstraintKinds+ DataKinds+ DefaultSignatures+ DeriveDataTypeable+ DeriveFoldable+ DeriveFunctor+ DeriveGeneric+ DeriveTraversable+ DoAndIfThenElse+ EmptyDataDecls+ ExistentialQuantification+ FlexibleContexts+ FlexibleInstances+ FunctionalDependencies+ GADTs+ GeneralizedNewtypeDeriving+ InstanceSigs+ KindSignatures+ LambdaCase+ MultiParamTypeClasses+ MultiWayIf+ NamedFieldPuns+ NoImplicitPrelude+ OverloadedStrings+ OverloadedLists+ PartialTypeSignatures+ PatternGuards+ PolyKinds+ RankNTypes+ RecordWildCards+ ScopedTypeVariables+ StandaloneDeriving+ TupleSections+ TypeFamilies+ TypeSynonymInstances+ ViewPatterns+ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ base >=4.11 && <10+ , base64+ , binary+ , bytestring+ , gltf-codec+ , gltf-loader+ , hspec+ , linear+ , microlens+ , rio >=0.1.12.0+ , unordered-containers+ default-language: Haskell2010
+ src/Text/GLTF/Loader.hs view
@@ -0,0 +1,39 @@+module Text.GLTF.Loader+ ( fromByteString,+ fromFile,+ + module Text.GLTF.Loader.Errors,+ module Text.GLTF.Loader.Gltf+ ) where++import Text.GLTF.Loader.Adapter+import Text.GLTF.Loader.BufferAccessor+import Text.GLTF.Loader.Errors+import Text.GLTF.Loader.Gltf++import Data.Either+import Lens.Micro+import RIO+ ( Monad((>>=)),+ IsString(fromString),+ String,+ (<$>),+ (.),+ MonadIO(liftIO),+ MonadUnliftIO,+ ByteString,+ FilePath )+import qualified Codec.GlTF as GlTF++fromByteString :: MonadUnliftIO io => ByteString -> io (Either Errors Gltf)+fromByteString = toGltfResult . GlTF.fromByteString++fromFile :: MonadUnliftIO io => FilePath -> io (Either Errors Gltf)+fromFile path = liftIO (GlTF.fromFile path) >>= toGltfResult+ +toGltfResult :: MonadUnliftIO io => Either String GlTF.GlTF -> io (Either Errors Gltf)+toGltfResult res+ = res+ & over _Left (ReadError . fromString)+ & traverseOf _Right toGltfResult'+ where toGltfResult' gltf = adaptGltf gltf <$> loadBuffers gltf
+ src/Text/GLTF/Loader/Adapter.hs view
@@ -0,0 +1,108 @@+-- |Transform a `Codec.GlTF.GlTF` to `Text.GLTF.Loader.Gltf.Gltf`+module Text.GLTF.Loader.Adapter+ ( attributePosition,+ attributeNormal,+ adaptGltf,+ adaptAsset,+ adaptMeshes,+ adaptNodes,+ adaptMesh,+ adaptNode,+ adaptMeshPrimitives,+ adaptMeshPrimitive,+ adaptMeshPrimitiveMode+ ) where++import Text.GLTF.Loader.BufferAccessor+import Text.GLTF.Loader.Gltf++import Linear (V3(..), V4(..))+import RIO+import RIO.Partial (toEnum)+import qualified Codec.GlTF as GlTF+import qualified Codec.GlTF.Asset as GlTF.Asset+import qualified Codec.GlTF.Mesh as GlTF.Mesh+import qualified Codec.GlTF.Node as GlTF.Node+import qualified Data.HashMap.Strict as HashMap++attributePosition :: Text+attributePosition = "POSITION"++attributeNormal :: Text+attributeNormal = "NORMAL"+++adaptGltf :: GlTF.GlTF -> Vector GltfBuffer -> Gltf+adaptGltf gltf@GlTF.GlTF{..} buffers' = Gltf+ { gltfAsset = adaptAsset asset,+ gltfMeshes = adaptMeshes gltf buffers' meshes,+ gltfNodes = adaptNodes nodes+ }++adaptAsset :: GlTF.Asset.Asset -> Asset+adaptAsset GlTF.Asset.Asset{..} = Asset+ { assetVersion = version,+ assetCopyright = copyright,+ assetGenerator = generator,+ assetMinVersion = minVersion+ }++adaptMeshes+ :: GlTF.GlTF+ -> Vector GltfBuffer+ -> Maybe (Vector GlTF.Mesh.Mesh)+ -> [Mesh]+adaptMeshes gltf buffers' = maybe [] (map (adaptMesh gltf buffers') . toList)++adaptNodes :: Maybe (Vector GlTF.Node.Node) -> [Node]+adaptNodes = maybe [] (map adaptNode . toList)++adaptMesh+ :: GlTF.GlTF+ -> Vector GltfBuffer+ -> GlTF.Mesh.Mesh+ -> Mesh+adaptMesh gltf buffers' GlTF.Mesh.Mesh{..} = Mesh+ { meshPrimitives = adaptMeshPrimitives gltf buffers' primitives,+ meshWeights = maybe [] toList weights,+ meshName = name+ }++adaptNode :: GlTF.Node.Node -> Node+adaptNode GlTF.Node.Node{..} = Node+ { nodeMeshId = GlTF.Mesh.unMeshIx <$> mesh,+ nodeName = name,+ nodeRotation = toV4 <$> rotation,+ nodeScale = toV3 <$> scale,+ nodeTranslation = toV3 <$> translation,+ nodeWeights = maybe [] toList weights+ }++adaptMeshPrimitives+ :: GlTF.GlTF+ -> Vector GltfBuffer+ -> Vector GlTF.Mesh.MeshPrimitive+ -> [MeshPrimitive]+adaptMeshPrimitives gltf buffers' = map (adaptMeshPrimitive gltf buffers') . toList++adaptMeshPrimitive+ :: GlTF.GlTF+ -> Vector GltfBuffer+ -> GlTF.Mesh.MeshPrimitive+ -> MeshPrimitive+adaptMeshPrimitive gltf buffers' GlTF.Mesh.MeshPrimitive{..} = MeshPrimitive+ { meshPrimitiveMode = adaptMeshPrimitiveMode mode,+ meshPrimitiveIndices = maybe [] (vertexIndices gltf buffers') indices,+ meshPrimitivePositions = maybe [] (vertexPositions gltf buffers') positions,+ meshPrimitiveNormals = []+ }+ where positions = attributes HashMap.!? attributePosition++adaptMeshPrimitiveMode :: GlTF.Mesh.MeshPrimitiveMode -> MeshPrimitiveMode+adaptMeshPrimitiveMode = toEnum . GlTF.Mesh.unMeshPrimitiveMode++toV3 :: (a, a, a) -> V3 a+toV3 (x, y, z) = V3 x y z++toV4 :: (a, a, a, a) -> V4 a+toV4 (w, x, y, z) = V4 w x y z
+ src/Text/GLTF/Loader/BufferAccessor.hs view
@@ -0,0 +1,236 @@+module Text.GLTF.Loader.BufferAccessor+ ( GltfBuffer(..),+ -- * Loading GLTF buffers+ loadBuffers,+ -- * Deserializing Accessors+ vertexIndices,+ vertexPositions,+ vertexNormals,+ -- * Binary Get decoders+ -- ** Specific Type decoders+ getIndices,+ getPositions,+ -- ** GLTF Accessor Type decoders+ getScalar,+ getVec2,+ getVec3,+ getVec4,+ getMat2,+ getMat3,+ getMat4,+ -- ** GLTF Component Type decoders+ getByte,+ getUnsignedByte,+ getShort,+ getUnsignedShort,+ getUnsignedInt,+ getFloat+ ) where++import Codec.GlTF.Accessor+import Codec.GlTF.Buffer+import Codec.GlTF.BufferView+import Codec.GlTF.URI+import Codec.GlTF+import Data.Binary.Get+import Data.ByteString.Lazy (fromStrict)+import Foreign.Storable+import Linear+import RIO hiding (min, max)+import qualified RIO.Vector as Vector+import qualified RIO.ByteString as ByteString++newtype GltfBuffer = GltfBuffer { unBuffer :: ByteString }+ deriving (Eq, Show)++data BufferAccessor = BufferAccessor+ { offset :: Int,+ count :: Int,+ buffer :: GltfBuffer+ }++loadBuffers :: MonadUnliftIO io => GlTF -> io (Vector GltfBuffer)+loadBuffers GlTF{buffers=buffers} = do+ let buffers' = fromMaybe [] buffers++ Vector.forM buffers' $ \Buffer{..} -> do+ payload <-+ maybe+ (return "")+ (\uri' -> do+ readRes <- liftIO $ loadURI undefined uri'+ case readRes of+ Left err -> error err+ Right res -> return res)+ uri+ + return $ GltfBuffer payload++vertexIndices :: GlTF -> Vector GltfBuffer -> AccessorIx -> [Int]+vertexIndices = readBufferWithGet getIndices++vertexPositions :: GlTF -> Vector GltfBuffer -> AccessorIx -> [V3 Float]+vertexPositions = readBufferWithGet getPositions++vertexNormals :: GlTF -> Vector GltfBuffer -> AccessorIx -> [V3 Float]+vertexNormals = undefined++readBufferWithGet+ :: Storable storable+ => Get [storable]+ -> GlTF+ -> Vector GltfBuffer+ -> AccessorIx+ -> [storable]+readBufferWithGet getter gltf buffers' accessorId+ = maybe []+ (readFromBuffer undefined getter)+ (bufferAccessor gltf buffers' accessorId)++bufferAccessor+ :: GlTF+ -> Vector GltfBuffer+ -> AccessorIx+ -> Maybe BufferAccessor+bufferAccessor GlTF{..} buffers' accessorId = do+ accessor <- lookupAccessor accessorId =<< accessors+ bufferView <- lookupBufferViewFromAccessor accessor =<< bufferViews+ buffer <- lookupBufferFromBufferView bufferView buffers'++ let Accessor{byteOffset=offset, count=count} = accessor+ BufferView{byteOffset=offset'} = bufferView++ return $ BufferAccessor+ { offset = offset + offset',+ count = count,+ buffer = buffer+ }++lookupBufferViewFromAccessor :: Accessor -> Vector BufferView -> Maybe BufferView+lookupBufferViewFromAccessor Accessor{..} bufferViews+ = bufferView >>= flip lookupBufferView bufferViews++lookupBufferFromBufferView :: BufferView -> Vector GltfBuffer -> Maybe GltfBuffer+lookupBufferFromBufferView BufferView{..} = lookupBuffer buffer++lookupAccessor :: AccessorIx -> Vector Accessor -> Maybe Accessor+lookupAccessor (AccessorIx accessorId) = (Vector.!? accessorId)++lookupBufferView :: BufferViewIx -> Vector BufferView -> Maybe BufferView+lookupBufferView (BufferViewIx bufferViewId) = (Vector.!? bufferViewId)++lookupBuffer :: BufferIx -> Vector GltfBuffer -> Maybe GltfBuffer+lookupBuffer (BufferIx bufferId) = (Vector.!? bufferId)++readFromBuffer+ :: Storable storable+ => storable+ -> Get [storable]+ -> BufferAccessor+ -> [storable]+readFromBuffer storable getter BufferAccessor{..}+ = runGet getter (fromStrict payload')+ where payload' = ByteString.take len' . ByteString.drop offset . unBuffer $ buffer+ len' = count * sizeOf storable++getIndices :: Get [Int]+getIndices = getScalar (fromIntegral <$> getUnsignedShort)++getPositions :: Get [V3 Float]+getPositions = getVec3 getFloat++getScalar :: Get a -> Get [a]+getScalar = getList++getVec2 :: Get a -> Get [V2 a]+getVec2 getter = getList $ V2 <$> getter <*> getter++getVec3 :: Get a -> Get [V3 a]+getVec3 getter = getList $ V3 <$> getter <*> getter <*> getter++getVec4 :: Get a -> Get [V4 a]+getVec4 getter = getList $ V4 <$> getter <*> getter <*> getter <*> getter++getMat2 :: Get a -> Get [M22 a]+getMat2 getter = getList $ do+ m1_1 <- getter+ m1_2 <- getter++ m2_1 <- getter+ m2_2 <- getter++ return $ V2+ (V2 m1_1 m2_1)+ (V2 m1_2 m2_2)++getMat3 :: Get a -> Get [M33 a]+getMat3 getter = getList $ do+ m1_1 <- getter+ m1_2 <- getter+ m1_3 <- getter+ + m2_1 <- getter+ m2_2 <- getter+ m2_3 <- getter++ m3_1 <- getter+ m3_2 <- getter+ m3_3 <- getter++ return $ V3+ (V3 m1_1 m2_1 m3_1)+ (V3 m1_2 m2_2 m3_2)+ (V3 m1_3 m2_3 m3_3)++getMat4 :: Get a -> Get [M44 a]+getMat4 getter = getList $ do+ m1_1 <- getter+ m1_2 <- getter+ m1_3 <- getter+ m1_4 <- getter+ + m2_1 <- getter+ m2_2 <- getter+ m2_3 <- getter+ m2_4 <- getter++ m3_1 <- getter+ m3_2 <- getter+ m3_3 <- getter+ m3_4 <- getter++ m4_1 <- getter+ m4_2 <- getter+ m4_3 <- getter+ m4_4 <- getter++ return $ V4+ (V4 m1_1 m2_1 m3_1 m4_1)+ (V4 m1_2 m2_2 m3_2 m4_2)+ (V4 m1_3 m2_3 m3_3 m4_3)+ (V4 m1_4 m2_4 m3_4 m4_4)++getByte :: Get Int8+getByte = getInt8++getUnsignedByte :: Get Word8+getUnsignedByte = getWord8++getShort :: Get Int16+getShort = getInt16le++getUnsignedShort :: Get Word16+getUnsignedShort = getWord16le++getUnsignedInt :: Get Word32+getUnsignedInt = getWord32le++getFloat :: Get Float+getFloat = getFloatle++getList :: Get a -> Get [a]+getList getter = do+ empty <- isEmpty+ if empty+ then return []+ else (:) <$> getter <*> getList getter
+ src/Text/GLTF/Loader/Errors.hs view
@@ -0,0 +1,28 @@+module Text.GLTF.Loader.Errors+ ( Errors(..),+ _ReadError,+ _ImpossibleError+ ) where++import Lens.Micro (Traversal'())+import RIO++data Errors+ = ReadError Text+ | ImpossibleError+ deriving (Show, Eq, Typeable)++instance Display Errors where+ textDisplay = displayErrorText++_ReadError :: Traversal' Errors Text+_ReadError f (ReadError text) = ReadError <$> f text+_ReadError _ err = pure err++_ImpossibleError :: Traversal' Errors ()+_ImpossibleError f ImpossibleError = f () $> ImpossibleError+_ImpossibleError _ err = pure err++displayErrorText :: Errors -> Text+displayErrorText (ReadError txt) = txt+displayErrorText ImpossibleError = "An impossible error has occurred!"
+ src/Text/GLTF/Loader/Gltf.hs view
@@ -0,0 +1,157 @@+module Text.GLTF.Loader.Gltf+ ( -- * Data constructors+ Gltf(..),+ Asset(..),+ Mesh(..),+ Node(..),+ MeshPrimitive(..),+ MeshPrimitiveMode(..),+ -- * Lenses+ _asset,+ _meshes,+ _nodes,+ _assetVersion,+ _assetCopyright,+ _assetGenerator,+ _assetMinVersion,+ _meshPrimitives,+ _meshPrimitiveMode,+ _meshPrimitiveIndices,+ _meshPrimitivePositions,+ _meshPrimitiveNormals,+ _meshWeights,+ _meshName,+ _nodeMeshId,+ _nodeName,+ _nodeRotation,+ _nodeScale,+ _nodeTranslation,+ _nodeWeights+ ) where++import Linear.V3 (V3(..))+import Linear.V4 (V4(..))+import RIO++data Gltf = Gltf+ { gltfAsset :: Asset,+ gltfMeshes :: [Mesh],+ gltfNodes :: [Node] }+ deriving (Eq, Show)++data Asset = Asset+ { assetVersion :: Text,+ assetCopyright :: Maybe Text,+ assetGenerator :: Maybe Text,+ assetMinVersion :: Maybe Text+ } deriving (Eq, Show)++data Mesh = Mesh+ { meshPrimitives :: [MeshPrimitive],+ meshWeights :: [Float],+ meshName :: Maybe Text+ } deriving (Eq, Show)++data Node = Node+ { nodeMeshId :: Maybe Int,+ nodeName :: Maybe Text,+ nodeRotation :: Maybe (V4 Float),+ nodeScale :: Maybe (V3 Float),+ nodeTranslation :: Maybe (V3 Float),+ nodeWeights :: [Float]+ } deriving (Eq, Show)++data MeshPrimitive = MeshPrimitive+ { meshPrimitiveMode :: MeshPrimitiveMode,+ meshPrimitiveIndices :: [Int],+ meshPrimitivePositions :: [V3 Float],+ meshPrimitiveNormals :: [V3 Float]+ } deriving (Eq, Show)++data MeshPrimitiveMode+ = Points+ | Lines+ | LineLoop+ | LineStrip+ | Triangles+ | TriangleStrip+ | TriangleFan+ deriving (Eq, Enum, Show)++_asset :: Lens' Gltf Asset+_asset = lens gltfAsset (\gltf asset -> gltf { gltfAsset = asset })++_meshes :: Lens' Gltf [Mesh]+_meshes = lens gltfMeshes (\gltf meshes -> gltf { gltfMeshes = meshes })++_nodes :: Lens' Gltf [Node]+_nodes = lens gltfNodes (\gltf nodes -> gltf { gltfNodes = nodes })++_assetVersion :: Lens' Asset Text+_assetVersion = lens assetVersion (\asset version' -> asset { assetVersion = version' })++_assetCopyright :: Lens' Asset (Maybe Text)+_assetCopyright = lens+ assetCopyright+ (\asset copyright' -> asset { assetCopyright = copyright' })++_assetGenerator :: Lens' Asset (Maybe Text)+_assetGenerator = lens+ assetGenerator+ (\asset generator' -> asset { assetGenerator = generator' })++_assetMinVersion :: Lens' Asset (Maybe Text)+_assetMinVersion = lens+ assetMinVersion+ (\asset minVersion' -> asset { assetMinVersion = minVersion' })++_meshPrimitives :: Lens' Mesh [MeshPrimitive]+_meshPrimitives = lens+ meshPrimitives+ (\mesh primitives -> mesh { meshPrimitives = primitives })++_meshPrimitiveMode :: Lens' MeshPrimitive MeshPrimitiveMode+_meshPrimitiveMode = lens+ meshPrimitiveMode+ (\primitive' mode -> primitive' { meshPrimitiveMode = mode })++_meshPrimitiveIndices :: Lens' MeshPrimitive [Int]+_meshPrimitiveIndices = lens+ meshPrimitiveIndices+ (\primitive' indices -> primitive' { meshPrimitiveIndices = indices })++_meshPrimitivePositions :: Lens' MeshPrimitive [V3 Float]+_meshPrimitivePositions = lens+ meshPrimitivePositions+ (\primitive' positions -> primitive' { meshPrimitivePositions = positions })++_meshPrimitiveNormals :: Lens' MeshPrimitive [V3 Float]+_meshPrimitiveNormals = lens+ meshPrimitiveNormals+ (\primitive' normals -> primitive' { meshPrimitiveNormals = normals })+ +_meshWeights :: Lens' Mesh [Float]+_meshWeights = lens meshWeights (\mesh weights -> mesh { meshWeights = weights })++_meshName :: Lens' Mesh (Maybe Text)+_meshName = lens meshName (\mesh name -> mesh { meshName = name })++_nodeMeshId :: Lens' Node (Maybe Int)+_nodeMeshId = lens nodeMeshId (\node meshId -> node { nodeMeshId = meshId })++_nodeName :: Lens' Node (Maybe Text)+_nodeName = lens nodeName (\node name' -> node { nodeName = name' })++_nodeRotation :: Lens' Node (Maybe (V4 Float))+_nodeRotation = lens nodeRotation (\node rotation' -> node { nodeRotation = rotation' })++_nodeScale :: Lens' Node (Maybe (V3 Float))+_nodeScale = lens nodeScale (\node scale' -> node { nodeScale = scale' })++_nodeTranslation :: Lens' Node (Maybe (V3 Float))+_nodeTranslation = lens+ nodeTranslation+ (\node translation' -> node { nodeTranslation = translation' })++_nodeWeights :: Lens' Node [Float]+_nodeWeights = lens nodeWeights (\node weights' -> node { nodeWeights = weights' })
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/Text/GLTF/Loader/AdapterSpec.hs view
@@ -0,0 +1,167 @@+module Text.GLTF.Loader.AdapterSpec (spec) where++import Text.GLTF.Loader.Adapter+import Text.GLTF.Loader.BufferAccessor+import Text.GLTF.Loader.Gltf+import Text.GLTF.Loader.Test.MkGltf++import Linear (V3(..), V4(..))+import RIO+import Test.Hspec+import qualified Codec.GlTF.Mesh as Mesh+import qualified Codec.GlTF.Node as Node++spec :: Spec+spec = do+ let codecGltf = mkCodecGltf+ codecMeshPrimitive = mkCodecMeshPrimitive++ describe "adaptGltf" $ do+ it "Adapts a basic GlTF" $ do+ buffers' <- buffers+ adaptGltf codecGltf buffers' `shouldBe` loaderGltf++ describe "adaptAsset" $ do+ let codecAsset = mkCodecAsset+ + it "Adapts a basic asset" $ + adaptAsset codecAsset `shouldBe` loaderAsset++ describe "adaptMeshes" $ do+ let codecMesh = mkCodecMesh+ codecMesh' = mkCodecMesh { Mesh.weights = Just [3.1] }+ + it "Adapts a list of nodes" $ do+ buffers' <- buffers+ + let meshes = Just [codecMesh, codecMesh']+ adaptedMeshes = [loaderMesh, set _meshWeights [3.1] loaderMesh]++ adaptMeshes codecGltf buffers' meshes `shouldBe` adaptedMeshes++ it "Adapts empty meshes" $ do+ buffers' <- buffers+ + adaptMeshes codecGltf buffers' (Just []) `shouldBe` []+ adaptMeshes codecGltf buffers' Nothing `shouldBe` []++ describe "adaptNodes" $ do+ let codecNode = mkCodecNode+ codecNode' = codecNode { Node.rotation = Nothing }+ + it "Adapts a list of nodes" $ do+ let nodes = Just [codecNode, codecNode']+ adaptNodes nodes `shouldBe` [loaderNode, set _nodeRotation Nothing loaderNode]++ it "Adapts empty nodes" $ do+ adaptNodes (Just []) `shouldBe` []+ adaptNodes Nothing `shouldBe` []++ describe "adaptMesh" $ do+ let codecMesh = mkCodecMesh+ codecMesh' = mkCodecMesh { Mesh.weights = Nothing }+ codecMesh'' = mkCodecMesh { Mesh.weights = Just [] }+ + it "Adapts a basic mesh" $ do+ buffers' <- buffers+ adaptMesh codecGltf buffers' codecMesh `shouldBe` loaderMesh++ it "Adapts empty weights" $ do+ buffers' <- buffers+ let meshEmptyWeight = set _meshWeights [] loaderMesh+ + adaptMesh codecGltf buffers' codecMesh' `shouldBe` meshEmptyWeight+ adaptMesh codecGltf buffers' codecMesh'' `shouldBe` meshEmptyWeight+ + describe "adaptNode" $ do+ let codecNode = mkCodecNode+ codecNode' = mkCodecNode { Node.weights = Nothing }+ codecNode'' = mkCodecNode { Node.weights = Just [] }+ + it "Adapts a basic node" $ do+ adaptNode codecNode `shouldBe` loaderNode++ it "Adapts empty weights" $ do+ let nodeEmptyWeight = set _nodeWeights [] loaderNode+ adaptNode codecNode' `shouldBe` nodeEmptyWeight+ adaptNode codecNode'' `shouldBe` nodeEmptyWeight++ describe "adaptMeshPrimitives" $ do+ let codecMeshPrimitive' = mkCodecMeshPrimitive+ { Mesh.mode = Mesh.MeshPrimitiveMode 0 }+ + it "adapts a list of primitives" $ do+ buffers' <- buffers+ let primitives = [codecMeshPrimitive, codecMeshPrimitive']+ expectedResult+ = [ loaderMeshPrimitive,+ set _meshPrimitiveMode Points loaderMeshPrimitive+ ]+ + adaptMeshPrimitives codecGltf buffers' primitives `shouldBe` expectedResult++ describe "adaptMeshPrimitive" $ do+ it "adapts a basic primitive" $ do+ buffers' <- buffers++ let codecMeshPrimitive' = mkCodecMeshPrimitive+ { Mesh.indices = Nothing }+ loaderMeshPrimitive' = set _meshPrimitiveIndices [] loaderMeshPrimitive+ + adaptMeshPrimitive codecGltf buffers' codecMeshPrimitive `shouldBe` loaderMeshPrimitive+ adaptMeshPrimitive codecGltf buffers' codecMeshPrimitive' `shouldBe` loaderMeshPrimitive'+ + describe "adaptMeshPrimitiveMode" $+ it "Adapts all expected modes" $ do+ adaptMeshPrimitiveMode Mesh.POINTS `shouldBe` Points+ adaptMeshPrimitiveMode Mesh.LINES `shouldBe` Lines+ adaptMeshPrimitiveMode Mesh.LINE_LOOP `shouldBe` LineLoop+ adaptMeshPrimitiveMode Mesh.LINE_STRIP `shouldBe` LineStrip+ adaptMeshPrimitiveMode Mesh.TRIANGLES `shouldBe` Triangles+ adaptMeshPrimitiveMode Mesh.TRIANGLE_STRIP `shouldBe` TriangleStrip+ adaptMeshPrimitiveMode Mesh.TRIANGLE_FAN `shouldBe` TriangleFan+ evaluate (adaptMeshPrimitiveMode $ Mesh.MeshPrimitiveMode 7)+ `shouldThrow` anyErrorCall++buffers :: MonadUnliftIO io => io (Vector GltfBuffer)+buffers = loadBuffers mkCodecGltf++loaderGltf :: Gltf+loaderGltf = Gltf+ { gltfAsset = loaderAsset,+ gltfMeshes = [loaderMesh],+ gltfNodes = [loaderNode]+ }++loaderAsset :: Asset+loaderAsset = Asset+ { assetVersion = "version",+ assetCopyright = Just "copyright",+ assetGenerator = Just "generator",+ assetMinVersion = Just "minVersion"+ }++loaderMesh :: Mesh+loaderMesh = Mesh+ { meshPrimitives = [loaderMeshPrimitive],+ meshWeights = [1.2],+ meshName = Just "mesh"+ }++loaderNode :: Node+loaderNode = Node+ { nodeMeshId = Just 5,+ nodeName = Just "node",+ nodeRotation = Just $ V4 1 2 3 4,+ nodeScale = Just $ V3 5 6 7,+ nodeTranslation = Just $ V3 8 9 10,+ nodeWeights = [11, 12, 13]+ }++loaderMeshPrimitive :: MeshPrimitive+loaderMeshPrimitive = MeshPrimitive+ { meshPrimitiveMode = Triangles,+ meshPrimitiveIndices = [1..4],+ meshPrimitivePositions = map (\x -> V3 x x x) [1..4],+ meshPrimitiveNormals = []+ }
+ test/Text/GLTF/Loader/BufferAccessorSpec.hs view
@@ -0,0 +1,94 @@+module Text.GLTF.Loader.BufferAccessorSpec (spec) where++import Text.GLTF.Loader.BufferAccessor+import Text.GLTF.Loader.Test.MkGltf++import Linear (V3(..))+import Data.Binary.Builder+import Data.Binary.Get (runGet)+import Data.Binary.Put (putFloatle, runPut)+import Data.ByteString.Lazy (fromStrict, toStrict)+import RIO+import RIO.Vector.Partial ((!))+import Test.Hspec+import qualified Codec.GlTF as GlTF+import qualified Codec.GlTF.Accessor as Accessor+import qualified Codec.GlTF.Buffer as Buffer+import qualified Codec.GlTF.BufferView as BufferView+import qualified Codec.GlTF.URI as URI++spec :: Spec+spec = do+ let gltf = mkCodecGltf+ + describe "loadBuffers" $ do+ it "Reads buffers from GlTF" $ do+ buffers <- loadBuffers gltf+ + let (GltfBuffer buffer') = buffers ! 0+ values = runGet (getScalar (fromIntegral <$> getUnsignedShort)) . fromStrict $ buffer'+ + values `shouldBe` ([1..4] :: [Integer])++ it "Handles malformed URI" $ do+ let gltf' = gltf+ { GlTF.buffers = Just+ [ mkCodecBufferIndices { Buffer.uri = Just $ URI.URI "uh oh!" } ]+ }++ loadBuffers gltf' `shouldThrow` anyException++ it "Handles no buffer" $ do+ let gltf' = gltf { GlTF.buffers = Nothing }+ buffers <- loadBuffers gltf'++ buffers `shouldBe` []+ + + describe "vertexIndices" $ do+ it "Reads basic values from buffer" $ do+ vertexIndices gltf buffers' accessorIdIndices `shouldBe` [1, 2, 3, 4]++ it "Returns empty when accessor not defined" $ do+ let gltf' = gltf { GlTF.accessors = Nothing } + vertexIndices gltf' buffers' accessorIdIndices `shouldBe` []++ it "Returns empty when buffer not found" $ do+ let bufferView = mkCodecBufferViewIndices { BufferView.buffer = Buffer.BufferIx 99 }+ gltf' = gltf { GlTF.bufferViews = Just [bufferView] }+ vertexIndices gltf' buffers' accessorIdIndices `shouldBe` []++ describe "vertexPositions" $ do+ it "Reads basic values from buffer" $ do+ vertexPositions gltf buffers' accessorIdPositions `shouldBe`+ [ V3 1 1 1,+ V3 2 2 2,+ V3 3 3 3,+ V3 4 4 4+ ]++ it "Returns empty when accessor not defined" $ do+ let gltf' = gltf { GlTF.accessors = Nothing } + vertexPositions gltf' buffers' accessorIdPositions `shouldBe` []++ it "Returns empty when buffer not found" $ do+ let bufferView = mkCodecBufferViewIndices { BufferView.buffer = Buffer.BufferIx 99 }+ gltf' = gltf { GlTF.bufferViews = Just [bufferView] }+ vertexPositions gltf' buffers' accessorIdPositions `shouldBe` []++buffers' :: Vector GltfBuffer+buffers' = [bufferIndices, bufferPositions]++accessorIdIndices :: Accessor.AccessorIx+accessorIdIndices = Accessor.AccessorIx 0++accessorIdPositions :: Accessor.AccessorIx+accessorIdPositions = Accessor.AccessorIx 1++bufferIndices :: GltfBuffer+bufferIndices = GltfBuffer . toStrict . toLazyByteString $ putIndices+ where putIndices = foldr ((<>) . putWord16le) empty ([1, 2, 3, 4] :: [Word16])++bufferPositions :: GltfBuffer+bufferPositions = GltfBuffer . toStrict . runPut $ putPositions+ where putPositions = mapM_ (replicateM_ 3 . putFloatle) ([1..4] :: [Float])
+ test/Text/GLTF/Loader/Test/MkGltf.hs view
@@ -0,0 +1,177 @@+module Text.GLTF.Loader.Test.MkGltf where++import Text.GLTF.Loader.Adapter (attributePosition)++import Data.Binary.Builder+import Data.Binary.Put (putFloatle, runPut)+import Data.ByteString.Base64 (encodeBase64)+import Data.ByteString.Lazy (toStrict)+import Foreign (Storable(..))+import Linear (V3(..))+import RIO+import qualified Codec.GlTF as GlTF+import qualified Codec.GlTF.Accessor as Accessor+import qualified Codec.GlTF.Asset as Asset+import qualified Codec.GlTF.Buffer as Buffer+import qualified Codec.GlTF.BufferView as BufferView+import qualified Codec.GlTF.Mesh as Mesh+import qualified Codec.GlTF.Node as Node+import qualified Codec.GlTF.URI as URI+import qualified Data.HashMap.Strict as HashMap++mkCodecGltf :: GlTF.GlTF+mkCodecGltf = GlTF.GlTF+ { asset = mkCodecAsset,+ extensionsUsed = Nothing,+ extensionsRequired = Nothing,+ accessors = Just [mkCodecAccessorIndices, mkCodecAccessorPositions],+ animations = Nothing,+ buffers = Just [mkCodecBufferIndices, mkCodecBufferPositions],+ bufferViews = Just [mkCodecBufferViewIndices, mkCodecBufferViewPositions],+ cameras = Nothing,+ images = Nothing,+ materials = Nothing,+ meshes = Just [mkCodecMesh],+ nodes = Just [mkCodecNode],+ samplers = Nothing,+ scenes = Nothing,+ skins = Nothing,+ textures = Nothing,+ extensions = Nothing,+ extras = Nothing+ }++mkCodecAsset :: Asset.Asset+mkCodecAsset = Asset.Asset+ { version = "version",+ copyright = Just "copyright",+ generator = Just "generator",+ minVersion = Just "minVersion",+ extensions = Nothing,+ extras = Nothing+ }++mkCodecAccessorIndices :: Accessor.Accessor+mkCodecAccessorIndices = Accessor.Accessor+ {+ bufferView = Just $ BufferView.BufferViewIx 0,+ byteOffset = 0,+ componentType = Accessor.ComponentType 5123,+ count = 4,+ extensions = Nothing,+ extras = Nothing,+ max = Nothing,+ min = Nothing,+ name = Just "Accessor Indices",+ normalized = False,+ sparse = Nothing,+ type' = Accessor.AttributeType "SCALAR"+ }++mkCodecAccessorPositions :: Accessor.Accessor+mkCodecAccessorPositions = Accessor.Accessor+ {+ bufferView = Just $ BufferView.BufferViewIx 1,+ byteOffset = 0,+ componentType = Accessor.ComponentType 5126,+ count = 4,+ extensions = Nothing,+ extras = Nothing,+ max = Nothing,+ min = Nothing,+ name = Just "Accessor Positions",+ normalized = False,+ sparse = Nothing,+ type' = Accessor.AttributeType "VEC3"+ }++mkCodecBufferViewIndices :: BufferView.BufferView+mkCodecBufferViewIndices = BufferView.BufferView+ { buffer = Buffer.BufferIx 0,+ byteOffset = 0,+ byteLength = sizeOf (undefined :: Word16) * 4,+ byteStride = Nothing,+ target = Nothing,+ name = Just "BufferView Indices",+ extensions = Nothing,+ extras = Nothing+ }++mkCodecBufferViewPositions :: BufferView.BufferView+mkCodecBufferViewPositions = BufferView.BufferView+ { buffer = Buffer.BufferIx 1,+ byteOffset = 0,+ byteLength = sizeOf (undefined :: V3 Float) * 4,+ byteStride = Nothing,+ target = Nothing,+ name = Just "BufferView Positions",+ extensions = Nothing,+ extras = Nothing+ }++mkCodecBufferIndices :: Buffer.Buffer+mkCodecBufferIndices = Buffer.Buffer+ { byteLength = sizeOf (undefined :: Word16) * 4,+ uri = Just mkCodecBufferUriIndices,+ extensions = Nothing,+ extras = Nothing,+ name = Just "Buffer Indices"+ }++mkCodecBufferPositions :: Buffer.Buffer+mkCodecBufferPositions = Buffer.Buffer+ { byteLength = sizeOf (undefined :: V3 Float) * 4,+ uri = Just mkCodecBufferUriPositions,+ extensions = Nothing,+ extras = Nothing,+ name = Just "Buffer Positions"+ }++mkCodecMesh :: Mesh.Mesh+mkCodecMesh = Mesh.Mesh+ { primitives = [mkCodecMeshPrimitive],+ weights = Just [1.2],+ name = Just "mesh",+ extensions = Nothing,+ extras = Nothing+ }++mkCodecBufferUriIndices :: URI.URI+mkCodecBufferUriIndices = URI.URI uriText+ where uriText = "data:application/octet-stream;base64," <> encodedText+ encodedText = encodeBase64. toStrict . toLazyByteString $ putIndices+ putIndices = foldr ((<>) . putWord16le) empty ([1..4] :: [Word16])++mkCodecBufferUriPositions :: URI.URI+mkCodecBufferUriPositions = URI.URI uriText+ where uriText = "data:application/octet-stream;base64," <> encodedText+ encodedText = encodeBase64. toStrict . runPut $ putPositions+ putPositions = mapM_ (replicateM_ 3 . putFloatle) ([1..4] :: [Float])++mkCodecMeshPrimitive :: Mesh.MeshPrimitive+mkCodecMeshPrimitive = Mesh.MeshPrimitive+ { attributes = HashMap.fromList+ [(attributePosition, Accessor.AccessorIx 1)],+ mode = Mesh.MeshPrimitiveMode 4,+ indices = Just $ Accessor.AccessorIx 0,+ material = Nothing,+ targets = Nothing,+ extensions = Nothing,+ extras = Nothing+ }++mkCodecNode :: Node.Node+mkCodecNode = Node.Node+ { camera = Nothing,+ children = Nothing,+ skin = Nothing,+ matrix = Nothing,+ mesh = Just (Mesh.MeshIx 5),+ rotation = Just (1, 2, 3, 4),+ scale = Just (5, 6, 7),+ translation = Just (8, 9, 10),+ weights = Just [11, 12, 13],+ name = Just "node",+ extensions = Nothing,+ extras = Nothing+ }
+ test/Text/GLTF/LoaderSpec.hs view
@@ -0,0 +1,93 @@+module Text.GLTF.LoaderSpec (spec) where++import Text.GLTF.Loader++import Lens.Micro+import Linear (V3(..))+import RIO+import Test.Hspec++spec :: Spec+spec = do+ describe "fromByteString" $ do+ it "Parses embedded gltf content" $ do+ gltfText <- readFileBinary "data/cube.gltf"+ res <- fromByteString gltfText+ res `shouldSatisfy` has _Right++ it "Fails on invalid content" $ do+ res <- fromByteString "Invalid GLTF"+ res `shouldSatisfy` has (_Left . _ReadError)++ describe "fromFile" $ do+ it "Parses embedded gltf file" $ do+ gltf <- fromFile "data/cube.gltf"+ gltf `shouldSatisfy` has _Right++ it "Parses expected nodes" $ do+ gltf <- fromFile "data/cube.gltf"+ let expected = Gltf+ { gltfAsset = Asset+ { assetVersion = "2.0",+ assetGenerator = Just "Khronos glTF Blender I/O v3.2.40",+ assetCopyright = Nothing,+ assetMinVersion = Nothing+ },++ gltfMeshes+ = [ Mesh+ { meshPrimitives+ = [ MeshPrimitive+ { meshPrimitiveMode = Triangles,+ meshPrimitiveIndices+ = [ 1, 14, 20, 1, 20, 7, 10, 6, 19, 10, 19, 23,+ 21, 18, 12, 21, 12, 15, 16, 3, 9, 16, 9,+ 22, 5, 2, 8, 5, 8, 11, 17, 13, 0, 17, 0, 4+ ],+ meshPrimitivePositions+ = [ V3 1.0 1.0 (-1.0), -- 1+ V3 1.0 1.0 (-1.0), -- 2+ V3 1.0 1.0 (-1.0), -- 3+ V3 1.0 (-1.0) (-1.0), -- 4+ V3 1.0 (-1.0) (-1.0), -- 5+ V3 1.0 (-1.0) (-1.0), -- 6+ V3 1.0 1.0 1.0, -- 7+ V3 1.0 1.0 1.0, -- 8+ V3 1.0 1.0 1.0, -- 9+ V3 1.0 (-1.0) 1.0, -- 10+ V3 1.0 (-1.0) 1.0, -- 11+ V3 1.0 (-1.0) 1.0, -- 12+ V3 (-1.0) 1.0 (-1.0), -- 13+ V3 (-1.0) 1.0 (-1.0), -- 14+ V3 (-1.0) 1.0 (-1.0), -- 15+ V3 (-1.0) (-1.0) (-1.0),-- 16+ V3 (-1.0) (-1.0) (-1.0),-- 17+ V3 (-1.0) (-1.0) (-1.0),-- 18+ V3 (-1.0) 1.0 1.0, -- 19+ V3 (-1.0) 1.0 1.0, -- 20+ V3 (-1.0) 1.0 1.0, -- 21+ V3 (-1.0) (-1.0) 1.0, -- 22+ V3 (-1.0) (-1.0) 1.0, -- 23+ V3 (-1.0) (-1.0) 1.0 -- 24+ ],+ meshPrimitiveNormals = []+ }+ ],+ meshWeights = [],+ meshName = Just "Cube"+ }+ ],++ gltfNodes+ = [ Node+ { nodeMeshId = Just 0,+ nodeName = Just "Cube",+ nodeRotation = Nothing,+ nodeScale = Nothing,+ nodeTranslation = Nothing,+ nodeWeights = []+ }+ ]+ }+ + gltf `shouldBe` Right expected