module Codec.Ktx.KeyValue
( KeyValueData
, pattern KTXcubemapIncomplete
, pattern KTXanimData
, pattern KTXastcDecodeMode
, pattern KTXwriterScParams
, pattern KTXwriter
, pattern KTXswizzle
, pattern KTXmetalPixelFormat
, pattern KTXdxgiFormat__
, pattern KTXglFormat
, pattern KTXorientation
, Value(..)
, text
, bytes
, number
, FromValue(..)
, textual
, getDataLe
, getData
, putDataLe
, putData
) where
import Data.Binary.Get (Get, getWord32le, getByteString, isolate, skip)
import Data.Binary.Put (Put, putByteString, putWord32le)
import Data.ByteString (ByteString)
import Data.ByteString qualified as BS
import Data.Foldable (for_)
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Text (Text)
import Data.Text qualified as Text (pack)
import Data.Text.Encoding qualified as Text
import Data.Word (Word32)
import GHC.Generics (Generic)
type KeyValueData = Map Text Value
newtype Value = Value ByteString
deriving (Value -> Value -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Value -> Value -> Bool
$c/= :: Value -> Value -> Bool
== :: Value -> Value -> Bool
$c== :: Value -> Value -> Bool
Eq, Int -> Value -> ShowS
[Value] -> ShowS
Value -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Value] -> ShowS
$cshowList :: [Value] -> ShowS
show :: Value -> String
$cshow :: Value -> String
showsPrec :: Int -> Value -> ShowS
$cshowsPrec :: Int -> Value -> ShowS
Show, forall x. Rep Value x -> Value
forall x. Value -> Rep Value x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Value x -> Value
$cfrom :: forall x. Value -> Rep Value x
Generic)
class FromValue a where
fromValue :: Value -> Maybe a
instance FromValue Text where
fromValue :: Value -> Maybe Text
fromValue (Value ByteString
bs)
| ByteString -> Bool
BS.null ByteString
bs =
forall a. Maybe a
Nothing
| HasCallStack => ByteString -> Word8
BS.last ByteString
bs forall a. Eq a => a -> a -> Bool
== Word8
0x00 =
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
ByteString -> Either UnicodeException Text
Text.decodeUtf8' forall a b. (a -> b) -> a -> b
$ HasCallStack => ByteString -> ByteString
BS.init ByteString
bs
| Bool
otherwise =
forall a. Maybe a
Nothing
instance FromValue ByteString where
fromValue :: Value -> Maybe ByteString
fromValue (Value ByteString
bs) = forall a. a -> Maybe a
Just ByteString
bs
text :: Text -> Value
text :: Text -> Value
text Text
t = ByteString -> Value
Value forall a b. (a -> b) -> a -> b
$ ByteString -> Word8 -> ByteString
BS.snoc (Text -> ByteString
Text.encodeUtf8 Text
t) Word8
0x00
bytes :: ByteString -> Value
bytes :: ByteString -> Value
bytes = ByteString -> Value
Value
number :: (Num a, Show a) => a -> Value
number :: forall a. (Num a, Show a) => a -> Value
number = Text -> Value
text forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show
textual :: KeyValueData -> Map Text Text
textual :: KeyValueData -> Map Text Text
textual = forall a b k. (a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybe forall a. FromValue a => Value -> Maybe a
fromValue
{-# INLINE getDataLe #-}
getDataLe :: Int -> Get KeyValueData
getDataLe :: Int -> Get KeyValueData
getDataLe = Get Word32 -> Int -> Get KeyValueData
getData Get Word32
getWord32le
getData :: Get Word32 -> Int -> Get KeyValueData
getData :: Get Word32 -> Int -> Get KeyValueData
getData Get Word32
getSize Int
bytesOfKeyValueData =
forall a. Int -> Get a -> Get a
isolate Int
bytesOfKeyValueData forall a b. (a -> b) -> a -> b
$
Int -> [(Text, Value)] -> Get KeyValueData
go Int
bytesOfKeyValueData []
where
go :: Int -> [(Text, Value)] -> Get KeyValueData
go Int
remains [(Text, Value)]
acc
| Int
remains forall a. Eq a => a -> a -> Bool
== Int
0 =
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Text, Value)]
acc
| Int
remains forall a. Ord a => a -> a -> Bool
< Int
0 =
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Attempted to read beyond bytesOfKeyValueData"
| Bool
otherwise = do
Int
keyAndValueByteSize <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (Integral a, Num b) => a -> b
fromIntegral Get Word32
getSize
let paddingSize :: Int
paddingSize = Int
3 forall a. Num a => a -> a -> a
- ((Int
keyAndValueByteSize forall a. Num a => a -> a -> a
+ Int
3) forall a. Integral a => a -> a -> a
`rem` Int
4)
ByteString
keyAndValue <- Int -> Get ByteString
getByteString Int
keyAndValueByteSize
Int -> Get ()
skip Int
paddingSize
let
(ByteString
keyBS, ByteString
valueBS) = (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
BS.span (forall a. Eq a => a -> a -> Bool
/= Word8
0x00) ByteString
keyAndValue
key :: Text
key = ByteString -> Text
Text.decodeUtf8 ByteString
keyBS
value :: Value
value = ByteString -> Value
Value forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.drop Int
1 ByteString
valueBS
Int -> [(Text, Value)] -> Get KeyValueData
go
(Int
remains forall a. Num a => a -> a -> a
- Int
keyAndValueByteSize forall a. Num a => a -> a -> a
- Int
4 forall a. Num a => a -> a -> a
- Int
paddingSize)
((Text
key, Value
value) forall a. a -> [a] -> [a]
: [(Text, Value)]
acc)
{-# INLINE putDataLe #-}
putDataLe :: KeyValueData -> Put
putDataLe :: KeyValueData -> Put
putDataLe = (Word32 -> Put) -> KeyValueData -> Put
putData Word32 -> Put
putWord32le
putData :: (Word32 -> Put) -> KeyValueData -> Put
putData :: (Word32 -> Put) -> KeyValueData -> Put
putData Word32 -> Put
putSize KeyValueData
kvs =
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (forall k a. Map k a -> [(k, a)]
Map.toList KeyValueData
kvs) \(Text
key, Value ByteString
value) -> do
let
keyAndValue :: ByteString
keyAndValue = forall a. Monoid a => [a] -> a
mconcat [Text -> ByteString
Text.encodeUtf8 Text
key, Word8 -> ByteString
BS.singleton Word8
0x00, ByteString
value]
keyAndValueByteSize :: Int
keyAndValueByteSize = ByteString -> Int
BS.length ByteString
keyAndValue
paddingSize :: Int
paddingSize = Int
3 forall a. Num a => a -> a -> a
- ((Int
keyAndValueByteSize forall a. Num a => a -> a -> a
+ Int
3) forall a. Integral a => a -> a -> a
`rem` Int
4)
Word32 -> Put
putSize (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
keyAndValueByteSize)
ByteString -> Put
putByteString ByteString
keyAndValue
ByteString -> Put
putByteString forall a b. (a -> b) -> a -> b
$ Int -> Word8 -> ByteString
BS.replicate Int
paddingSize Word8
0
pattern KTXcubemapIncomplete :: Text
pattern $bKTXcubemapIncomplete :: Text
$mKTXcubemapIncomplete :: forall {r}. Text -> ((# #) -> r) -> ((# #) -> r) -> r
KTXcubemapIncomplete = "KTXcubemapIncomplete"
pattern KTXorientation :: Text
pattern $bKTXorientation :: Text
$mKTXorientation :: forall {r}. Text -> ((# #) -> r) -> ((# #) -> r) -> r
KTXorientation = "KTXorientation"
pattern KTXglFormat :: Text
pattern $bKTXglFormat :: Text
$mKTXglFormat :: forall {r}. Text -> ((# #) -> r) -> ((# #) -> r) -> r
KTXglFormat = "KTXglFormat"
pattern KTXdxgiFormat__ :: Text
pattern $bKTXdxgiFormat__ :: Text
$mKTXdxgiFormat__ :: forall {r}. Text -> ((# #) -> r) -> ((# #) -> r) -> r
KTXdxgiFormat__ = "KTXdxgiFormat__"
pattern KTXmetalPixelFormat :: Text
pattern $bKTXmetalPixelFormat :: Text
$mKTXmetalPixelFormat :: forall {r}. Text -> ((# #) -> r) -> ((# #) -> r) -> r
KTXmetalPixelFormat = "KTXmetalPixelFormat"
pattern KTXswizzle :: Text
pattern $bKTXswizzle :: Text
$mKTXswizzle :: forall {r}. Text -> ((# #) -> r) -> ((# #) -> r) -> r
KTXswizzle = "KTXswizzle"
pattern KTXwriter :: Text
pattern $bKTXwriter :: Text
$mKTXwriter :: forall {r}. Text -> ((# #) -> r) -> ((# #) -> r) -> r
KTXwriter = "KTXwriter"
pattern KTXwriterScParams :: Text
pattern $bKTXwriterScParams :: Text
$mKTXwriterScParams :: forall {r}. Text -> ((# #) -> r) -> ((# #) -> r) -> r
KTXwriterScParams = "KTXwriterScParams"
pattern KTXastcDecodeMode :: Text
pattern $bKTXastcDecodeMode :: Text
$mKTXastcDecodeMode :: forall {r}. Text -> ((# #) -> r) -> ((# #) -> r) -> r
KTXastcDecodeMode = "KTXastcDecodeMode"
pattern KTXanimData :: Text
pattern $bKTXanimData :: Text
$mKTXanimData :: forall {r}. Text -> ((# #) -> r) -> ((# #) -> r) -> r
KTXanimData = "KTXanimData"