module Codec.Ktx.KeyValue
  ( KeyValueData
  , lookup
  , insertBytes
  , insertNumber
  , insertText

    -- * Predefined keys

    -- $predefined
  , pattern KTXcubemapIncomplete
  , pattern KTXanimData
  , pattern KTXastcDecodeMode
  , pattern KTXwriterScParams
  , pattern KTXwriter
  , setWriterWith
  , writerKtxCodecWith
  , writerKtxCodec
  , 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 Prelude hiding (lookup)

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, unpack)
import Data.Text.Encoding qualified as Text
import Data.Version
import Data.Word (Word32)
import GHC.Generics (Generic)
import Text.Read (readMaybe)

import Paths_ktx_codec qualified as Paths

type KeyValueData = Map Text Value

{- | A wrapper for raw data.

Use "FromValue"/"ToValue" to process.
-}
newtype Value = Value ByteString
  deriving (Value -> Value -> Bool
(Value -> Value -> Bool) -> (Value -> Value -> Bool) -> Eq Value
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Value -> Value -> Bool
== :: Value -> Value -> Bool
$c/= :: Value -> Value -> Bool
/= :: Value -> Value -> Bool
Eq, Int -> Value -> ShowS
[Value] -> ShowS
Value -> String
(Int -> Value -> ShowS)
-> (Value -> String) -> ([Value] -> ShowS) -> Show Value
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Value -> ShowS
showsPrec :: Int -> Value -> ShowS
$cshow :: Value -> String
show :: Value -> String
$cshowList :: [Value] -> ShowS
showList :: [Value] -> ShowS
Show, (forall x. Value -> Rep Value x)
-> (forall x. Rep Value x -> Value) -> Generic Value
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
$cfrom :: forall x. Value -> Rep Value x
from :: forall x. Value -> Rep Value x
$cto :: forall x. Rep Value x -> Value
to :: forall x. Rep Value x -> Value
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 =
        Maybe Text
forall a. Maybe a
Nothing
    | HasCallStack => ByteString -> Word8
ByteString -> Word8
BS.last ByteString
bs Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0x00 =
        (UnicodeException -> Maybe Text)
-> (Text -> Maybe Text)
-> Either UnicodeException Text
-> Maybe Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe Text -> UnicodeException -> Maybe Text
forall a b. a -> b -> a
const Maybe Text
forall a. Maybe a
Nothing) Text -> Maybe Text
forall a. a -> Maybe a
Just (Either UnicodeException Text -> Maybe Text)
-> Either UnicodeException Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$
          ByteString -> Either UnicodeException Text
Text.decodeUtf8' (ByteString -> Either UnicodeException Text)
-> ByteString -> Either UnicodeException Text
forall a b. (a -> b) -> a -> b
$ HasCallStack => ByteString -> ByteString
ByteString -> ByteString
BS.init ByteString
bs
    | Bool
otherwise =
        Maybe Text
forall a. Maybe a
Nothing

instance FromValue ByteString where
  fromValue :: Value -> Maybe ByteString
fromValue (Value ByteString
bs) = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
bs

instance FromValue Integer where
  fromValue :: Value -> Maybe Integer
fromValue Value
val =
    Value -> Maybe Text
forall a. FromValue a => Value -> Maybe a
fromValue Value
val Maybe Text -> (Text -> Maybe Integer) -> Maybe Integer
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Maybe Integer
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe Integer)
-> (Text -> String) -> Text -> Maybe Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack

lookup :: FromValue a => Text -> KeyValueData -> Maybe a
lookup :: forall a. FromValue a => Text -> KeyValueData -> Maybe a
lookup Text
key KeyValueData
kvd = Text -> KeyValueData -> Maybe Value
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
key KeyValueData
kvd Maybe Value -> (Value -> Maybe a) -> Maybe a
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> Maybe a
forall a. FromValue a => Value -> Maybe a
fromValue

text :: Text -> Value
text :: Text -> Value
text Text
t = ByteString -> Value
Value (ByteString -> Value) -> ByteString -> 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 (Text -> Value) -> (a -> Text) -> a -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack (String -> Text) -> (a -> String) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show

insertText :: Text -> Text -> KeyValueData -> KeyValueData
insertText :: Text -> Text -> KeyValueData -> KeyValueData
insertText Text
key Text
value = Text -> Value -> KeyValueData -> KeyValueData
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
key (Text -> Value
text Text
value)

insertBytes :: Text -> ByteString -> KeyValueData -> KeyValueData
insertBytes :: Text -> ByteString -> KeyValueData -> KeyValueData
insertBytes Text
key ByteString
value = Text -> Value -> KeyValueData -> KeyValueData
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
key (ByteString -> Value
bytes ByteString
value)

insertNumber :: (Num a, Show a) => Text -> a -> KeyValueData -> KeyValueData
insertNumber :: forall a.
(Num a, Show a) =>
Text -> a -> KeyValueData -> KeyValueData
insertNumber Text
key a
value = Text -> Value -> KeyValueData -> KeyValueData
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
key (a -> Value
forall a. (Num a, Show a) => a -> Value
number a
value)

-- | Extract all valid (null-terminated utf8) values.
textual :: KeyValueData -> Map Text Text
textual :: KeyValueData -> Map Text Text
textual = (Value -> Maybe Text) -> KeyValueData -> Map Text Text
forall a b k. (a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybe Value -> Maybe Text
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 =
  Int -> Get KeyValueData -> Get KeyValueData
forall a. Int -> Get a -> Get a
isolate Int
bytesOfKeyValueData (Get KeyValueData -> Get KeyValueData)
-> Get KeyValueData -> Get KeyValueData
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 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 =
          KeyValueData -> Get KeyValueData
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (KeyValueData -> Get KeyValueData)
-> KeyValueData -> Get KeyValueData
forall a b. (a -> b) -> a -> b
$ [(Text, Value)] -> KeyValueData
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Text, Value)]
acc

      | Int
remains Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 =
          String -> Get KeyValueData
forall a. String -> Get a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Attempted to read beyond bytesOfKeyValueData"

      | Bool
otherwise = do
          Int
keyAndValueByteSize <- (Word32 -> Int) -> Get Word32 -> Get Int
forall a b. (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Get Word32
getSize
          let paddingSize :: Int
paddingSize = Int
3 Int -> Int -> Int
forall a. Num a => a -> a -> a
- ((Int
keyAndValueByteSize Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3) Int -> Int -> Int
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 (Word8 -> Word8 -> Bool
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 (ByteString -> Value) -> ByteString -> 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 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
keyAndValueByteSize Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
paddingSize)
            ((Text
key, Value
value) (Text, Value) -> [(Text, Value)] -> [(Text, 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 =
  [(Text, Value)] -> ((Text, Value) -> Put) -> Put
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (KeyValueData -> [(Text, Value)]
forall k a. Map k a -> [(k, a)]
Map.toList KeyValueData
kvs) \(Text
key, Value ByteString
value) -> do
    let
      keyAndValue :: ByteString
keyAndValue = [ByteString] -> ByteString
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
- ((Int
keyAndValueByteSize Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`rem` Int
4)

    Word32 -> Put
putSize (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
keyAndValueByteSize)
    ByteString -> Put
putByteString ByteString
keyAndValue
    ByteString -> Put
putByteString (ByteString -> Put) -> ByteString -> Put
forall a b. (a -> b) -> a -> b
$ Int -> Word8 -> ByteString
BS.replicate Int
paddingSize Word8
0

-- $predefined https://github.khronos.org/KTX-Specification/ktxspec.v2.html#_predefined_keyvalue_pairs

pattern KTXcubemapIncomplete :: Text
pattern $mKTXcubemapIncomplete :: forall {r}. Text -> ((# #) -> r) -> ((# #) -> r) -> r
$bKTXcubemapIncomplete :: Text
KTXcubemapIncomplete = "KTXcubemapIncomplete"

pattern KTXorientation :: Text
pattern $mKTXorientation :: forall {r}. Text -> ((# #) -> r) -> ((# #) -> r) -> r
$bKTXorientation :: Text
KTXorientation = "KTXorientation"

pattern KTXglFormat :: Text
pattern $mKTXglFormat :: forall {r}. Text -> ((# #) -> r) -> ((# #) -> r) -> r
$bKTXglFormat :: Text
KTXglFormat = "KTXglFormat"

pattern KTXdxgiFormat__ :: Text
pattern $mKTXdxgiFormat__ :: forall {r}. Text -> ((# #) -> r) -> ((# #) -> r) -> r
$bKTXdxgiFormat__ :: Text
KTXdxgiFormat__ = "KTXdxgiFormat__"

pattern KTXmetalPixelFormat :: Text
pattern $mKTXmetalPixelFormat :: forall {r}. Text -> ((# #) -> r) -> ((# #) -> r) -> r
$bKTXmetalPixelFormat :: Text
KTXmetalPixelFormat = "KTXmetalPixelFormat"

pattern KTXswizzle :: Text
pattern $mKTXswizzle :: forall {r}. Text -> ((# #) -> r) -> ((# #) -> r) -> r
$bKTXswizzle :: Text
KTXswizzle = "KTXswizzle"

{- | KTX file writers may, and are strongly encouraged to, identify themselves by including a value with the key @KTXwriter@

The value is a NUL-terminated UTF-8 string that will uniquely identify the tool writing the file, for example: @AcmeCo TexTool v1.0@.
Only the most recent writer should be identified. Editing tools must overwrite this value when rewriting a file originally written by a different tool.
-}
pattern KTXwriter :: Text
pattern $mKTXwriter :: forall {r}. Text -> ((# #) -> r) -> ((# #) -> r) -> r
$bKTXwriter :: Text
KTXwriter = "KTXwriter"

-- | Replace writer info with your own, using this package version as baseline.
setWriterWith :: (Text -> Text) -> KeyValueData -> KeyValueData
setWriterWith :: (Text -> Text) -> KeyValueData -> KeyValueData
setWriterWith Text -> Text
f = Text -> Value -> KeyValueData -> KeyValueData
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
KTXwriter ((Text -> Text) -> Value
writerKtxCodecWith Text -> Text
f)

-- | Attach your application/library version to the writer tag.
writerKtxCodecWith :: (Text -> Text) -> Value
writerKtxCodecWith :: (Text -> Text) -> Value
writerKtxCodecWith Text -> Text
f = Text -> Value
text (Text -> Value) -> (Text -> Text) -> Text -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
f (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ Text
"ktx-codec " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (Version -> String
showVersion Version
Paths.version)

-- | The value for the KTXwriter we ought to write when using this package to write or modify KTX files.
writerKtxCodec :: Value
writerKtxCodec :: Value
writerKtxCodec = (Text -> Text) -> Value
writerKtxCodecWith Text -> Text
forall a. a -> a
id

pattern KTXwriterScParams :: Text
pattern $mKTXwriterScParams :: forall {r}. Text -> ((# #) -> r) -> ((# #) -> r) -> r
$bKTXwriterScParams :: Text
KTXwriterScParams = "KTXwriterScParams"

pattern KTXastcDecodeMode :: Text
pattern $mKTXastcDecodeMode :: forall {r}. Text -> ((# #) -> r) -> ((# #) -> r) -> r
$bKTXastcDecodeMode :: Text
KTXastcDecodeMode = "KTXastcDecodeMode"

pattern KTXanimData :: Text
pattern $mKTXanimData :: forall {r}. Text -> ((# #) -> r) -> ((# #) -> r) -> r
$bKTXanimData :: Text
KTXanimData = "KTXanimData"