module Codec.Ktx.KeyValue
  ( KeyValueData

    -- * Predefined keys
  , pattern KTXcubemapIncomplete
  , pattern KTXanimData
  , pattern KTXastcDecodeMode
  , pattern KTXwriterScParams
  , pattern KTXwriter
  , pattern KTXswizzle
  , pattern KTXmetalPixelFormat
  , pattern KTXdxgiFormat__
  , pattern KTXglFormat
  , pattern KTXorientation

    -- * Writing
  , Value(..)
  , text
  , bytes
  , number

    -- * Reading
  , FromValue(..)
  , textual

    -- * Binary operations
  , 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

{- | A wrapper for raw data.

Use "FromValue"/"ToValue" to process.
-}
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

-- | Extract all valid (null-terminated utf8) values.
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

          {- XXX: Spec says:
              Any byte value is allowed.
              It is encouraged that the value be a NUL terminated UTF-8 string but this is not required.
              If the Value data is a string of bytes then the NUL termination
              should be included in the keyAndValueByteSize byte count
              (but programs that read KTX files must not rely on this).
          -}
          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"