{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StrictData #-}

module Codec.GLB
  ( GLB(..)
  , Header(..)
  , Chunk(..)
  , fromByteString
  , fromFile
  ) where

import Prelude hiding (length)

import Data.Binary (Binary(..), decodeFileOrFail, decodeOrFail)
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)

import qualified Data.ByteString.Lazy as BSL

fromByteString :: ByteString -> Either (ByteOffset, String) GLB
fromByteString :: ByteString -> Either (ByteOffset, String) GLB
fromByteString ByteString
bs =
  case ByteString
-> Either
     (ByteString, ByteOffset, String) (ByteString, ByteOffset, GLB)
forall a.
Binary a =>
ByteString
-> Either
     (ByteString, ByteOffset, String) (ByteString, ByteOffset, a)
decodeOrFail (ByteString -> ByteString
BSL.fromStrict ByteString
bs) of
    Right (ByteString
_leftovers, ByteOffset
_bytesLeft, GLB
ktx) ->
      GLB -> Either (ByteOffset, String) GLB
forall a b. b -> Either a b
Right GLB
ktx
    Left (ByteString
_leftovers, ByteOffset
bytesLeft, String
err) ->
      (ByteOffset, String) -> Either (ByteOffset, String) GLB
forall a b. a -> Either a b
Left (ByteOffset
bytesLeft, String
err)

fromFile :: FilePath -> IO (Either (ByteOffset, String) GLB)
fromFile :: String -> IO (Either (ByteOffset, String) GLB)
fromFile = String -> IO (Either (ByteOffset, String) GLB)
forall a. Binary a => String -> IO (Either (ByteOffset, String) a)
decodeFileOrFail

data GLB = GLB
  { GLB -> Header
header :: Header
  , GLB -> Vector Chunk
chunks :: Vector Chunk
  } deriving (GLB -> GLB -> Bool
(GLB -> GLB -> Bool) -> (GLB -> GLB -> Bool) -> Eq GLB
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: GLB -> GLB -> Bool
== :: GLB -> GLB -> Bool
$c/= :: GLB -> GLB -> Bool
/= :: GLB -> GLB -> Bool
Eq, Int -> GLB -> ShowS
[GLB] -> ShowS
GLB -> String
(Int -> GLB -> ShowS)
-> (GLB -> String) -> ([GLB] -> ShowS) -> Show GLB
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GLB -> ShowS
showsPrec :: Int -> GLB -> ShowS
$cshow :: GLB -> String
show :: GLB -> String
$cshowList :: [GLB] -> ShowS
showList :: [GLB] -> ShowS
Show, (forall x. GLB -> Rep GLB x)
-> (forall x. Rep GLB x -> GLB) -> Generic GLB
forall x. Rep GLB x -> GLB
forall x. GLB -> Rep GLB x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. GLB -> Rep GLB x
from :: forall x. GLB -> Rep GLB x
$cto :: forall x. Rep GLB x -> GLB
to :: forall x. Rep GLB x -> GLB
Generic)

instance Binary GLB where
  get :: Get GLB
get = Header -> Vector Chunk -> GLB
GLB (Header -> Vector Chunk -> GLB)
-> Get Header -> Get (Vector Chunk -> GLB)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Header
forall t. Binary t => Get t
get Get (Vector Chunk -> GLB) -> Get (Vector Chunk) -> Get GLB
forall a b. Get (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (() -> Get (Maybe (Chunk, ()))) -> () -> Get (Vector Chunk)
forall (m :: * -> *) b a.
Monad m =>
(b -> m (Maybe (a, b))) -> b -> m (Vector a)
unfoldrM () -> Get (Maybe (Chunk, ()))
forall {a}. Binary a => () -> Get (Maybe (a, ()))
getChunks ()
    where
      getChunks :: () -> Get (Maybe (a, ()))
getChunks () = do
        Bool
done <- Get Bool
isEmpty
        if Bool
done then
          Maybe (a, ()) -> Get (Maybe (a, ()))
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (a, ())
forall a. Maybe a
Nothing
        else do
          a
chunk <- Get a
forall t. Binary t => Get t
get
          pure $ (a, ()) -> Maybe (a, ())
forall a. a -> Maybe a
Just (a
chunk, ())

  put :: GLB -> Put
put GLB{Vector Chunk
Header
$sel:header:GLB :: GLB -> Header
$sel:chunks:GLB :: GLB -> Vector Chunk
header :: Header
chunks :: Vector Chunk
..} = do
    Header -> Put
forall t. Binary t => t -> Put
put Header
header
    (Chunk -> Put) -> Vector Chunk -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Chunk -> Put
forall t. Binary t => t -> Put
put Vector Chunk
chunks

data Header = Header
  { Header -> Word32
magic   :: Word32
  , Header -> Word32
version :: Word32
  , Header -> Word32
length  :: Word32
  } deriving (Header -> Header -> Bool
(Header -> Header -> Bool)
-> (Header -> Header -> Bool) -> Eq Header
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Header -> Header -> Bool
== :: Header -> Header -> Bool
$c/= :: Header -> Header -> Bool
/= :: Header -> Header -> Bool
Eq, Int -> Header -> ShowS
[Header] -> ShowS
Header -> String
(Int -> Header -> ShowS)
-> (Header -> String) -> ([Header] -> ShowS) -> Show Header
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Header -> ShowS
showsPrec :: Int -> Header -> ShowS
$cshow :: Header -> String
show :: Header -> String
$cshowList :: [Header] -> ShowS
showList :: [Header] -> ShowS
Show, (forall x. Header -> Rep Header x)
-> (forall x. Rep Header x -> Header) -> Generic Header
forall x. Rep Header x -> Header
forall x. Header -> Rep Header x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Header -> Rep Header x
from :: forall x. Header -> Rep Header x
$cto :: forall x. Rep Header x -> Header
to :: forall x. Rep Header x -> Header
Generic)

instance Binary Header where
  get :: Get Header
get = Word32 -> Word32 -> Word32 -> Header
Header
    (Word32 -> Word32 -> Word32 -> Header)
-> Get Word32 -> Get (Word32 -> Word32 -> Header)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word32
getWord32le
    Get (Word32 -> Word32 -> Header)
-> Get Word32 -> Get (Word32 -> Header)
forall a b. Get (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Word32
getWord32le
    Get (Word32 -> Header) -> Get Word32 -> Get Header
forall a b. Get (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Word32
getWord32le

  put :: Header -> Put
put Header{Word32
$sel:magic:Header :: Header -> Word32
$sel:version:Header :: Header -> Word32
$sel:length:Header :: Header -> Word32
magic :: Word32
version :: Word32
length :: Word32
..} = do
    Word32 -> Put
putWord32le Word32
magic
    Word32 -> Put
putWord32le Word32
version
    Word32 -> Put
putWord32le Word32
length

data Chunk = Chunk
  { Chunk -> Word32
chunkLength :: Word32
  , Chunk -> Word32
chunkType   :: Word32
  , Chunk -> ByteString
chunkData   :: ByteString
  }
  deriving (Chunk -> Chunk -> Bool
(Chunk -> Chunk -> Bool) -> (Chunk -> Chunk -> Bool) -> Eq Chunk
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Chunk -> Chunk -> Bool
== :: Chunk -> Chunk -> Bool
$c/= :: Chunk -> Chunk -> Bool
/= :: Chunk -> Chunk -> Bool
Eq, Int -> Chunk -> ShowS
[Chunk] -> ShowS
Chunk -> String
(Int -> Chunk -> ShowS)
-> (Chunk -> String) -> ([Chunk] -> ShowS) -> Show Chunk
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Chunk -> ShowS
showsPrec :: Int -> Chunk -> ShowS
$cshow :: Chunk -> String
show :: Chunk -> String
$cshowList :: [Chunk] -> ShowS
showList :: [Chunk] -> ShowS
Show, (forall x. Chunk -> Rep Chunk x)
-> (forall x. Rep Chunk x -> Chunk) -> Generic Chunk
forall x. Rep Chunk x -> Chunk
forall x. Chunk -> Rep Chunk x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Chunk -> Rep Chunk x
from :: forall x. Chunk -> Rep Chunk x
$cto :: forall x. Rep Chunk x -> Chunk
to :: forall x. Rep Chunk x -> Chunk
Generic)

instance Binary Chunk where
  get :: Get Chunk
get = do
    Word32
chunkLength <- Get Word32
getWord32le
    Word32
chunkType   <- Get Word32
getWord32le
    ByteString
chunkData   <- Int -> Get ByteString
getByteString (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
chunkLength)
    pure Chunk{Word32
ByteString
$sel:chunkLength:Chunk :: Word32
$sel:chunkType:Chunk :: Word32
$sel:chunkData:Chunk :: ByteString
chunkLength :: Word32
chunkType :: Word32
chunkData :: ByteString
..}

  put :: Chunk -> Put
put Chunk{Word32
ByteString
$sel:chunkLength:Chunk :: Chunk -> Word32
$sel:chunkType:Chunk :: Chunk -> Word32
$sel:chunkData:Chunk :: Chunk -> ByteString
chunkLength :: Word32
chunkType :: Word32
chunkData :: ByteString
..} = do
    Word32 -> Put
putWord32le   Word32
chunkLength
    Word32 -> Put
putWord32le   Word32
chunkType
    ByteString -> Put
putByteString ByteString
chunkData