KeyValue.hs

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 (Eq, Show, Generic)

class FromValue a where
  fromValue :: Value -> Maybe a

instance FromValue Text where
  fromValue (Value bs)
    | BS.null bs =
        Nothing
    | BS.last bs == 0x00 =
        either (const Nothing) Just $
          Text.decodeUtf8' $ BS.init bs
    | otherwise =
        Nothing

instance FromValue ByteString where
  fromValue (Value bs) = Just bs

instance FromValue Integer where
  fromValue val =
    fromValue val >>= readMaybe . Text.unpack

lookup :: FromValue a => Text -> KeyValueData -> Maybe a
lookup key kvd = Map.lookup key kvd >>= fromValue

text :: Text -> Value
text t = Value $ BS.snoc (Text.encodeUtf8 t) 0x00

bytes :: ByteString -> Value
bytes = Value

number :: (Num a, Show a) => a -> Value
number = text . Text.pack . show

insertText :: Text -> Text -> KeyValueData -> KeyValueData
insertText key value = Map.insert key (text value)

insertBytes :: Text -> ByteString -> KeyValueData -> KeyValueData
insertBytes key value = Map.insert key (bytes value)

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

-- | Extract all valid (null-terminated utf8) values.
textual :: KeyValueData -> Map Text Text
textual = Map.mapMaybe fromValue

{-# INLINE getDataLe #-}
getDataLe :: Int -> Get KeyValueData
getDataLe = getData getWord32le

getData :: Get Word32 -> Int -> Get KeyValueData
getData getSize bytesOfKeyValueData =
  isolate bytesOfKeyValueData $
    go bytesOfKeyValueData []
  where
    go remains acc
      | remains == 0 =
          pure $ Map.fromList acc

      | remains < 0 =
          fail "Attempted to read beyond bytesOfKeyValueData"

      | otherwise = do
          keyAndValueByteSize <- fmap fromIntegral getSize
          let paddingSize = 3 - ((keyAndValueByteSize + 3) `rem` 4)

          keyAndValue <- getByteString keyAndValueByteSize
          skip 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
            (keyBS, valueBS) = BS.span (/= 0x00) keyAndValue
            key = Text.decodeUtf8 keyBS
            value = Value $ BS.drop 1 valueBS

          go
            (remains - keyAndValueByteSize - 4 - paddingSize)
            ((key, value) : acc)

{-# INLINE putDataLe #-}
putDataLe :: KeyValueData -> Put
putDataLe = putData putWord32le

putData :: (Word32 -> Put) -> KeyValueData -> Put
putData putSize kvs =
  for_ (Map.toList kvs) \(key, Value value) -> do
    let
      keyAndValue = mconcat [Text.encodeUtf8 key, BS.singleton 0x00, value]
      keyAndValueByteSize = BS.length keyAndValue
      paddingSize = 3 - ((keyAndValueByteSize + 3) `rem` 4)

    putSize (fromIntegral keyAndValueByteSize)
    putByteString keyAndValue
    putByteString $ BS.replicate paddingSize 0

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

pattern KTXcubemapIncomplete :: Text
pattern KTXcubemapIncomplete = "KTXcubemapIncomplete"

pattern KTXorientation :: Text
pattern KTXorientation = "KTXorientation"

pattern KTXglFormat :: Text
pattern KTXglFormat = "KTXglFormat"

pattern KTXdxgiFormat__ :: Text
pattern KTXdxgiFormat__ = "KTXdxgiFormat__"

pattern KTXmetalPixelFormat :: Text
pattern KTXmetalPixelFormat = "KTXmetalPixelFormat"

pattern KTXswizzle :: Text
pattern 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 KTXwriter = "KTXwriter"

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

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

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

pattern KTXwriterScParams :: Text
pattern KTXwriterScParams = "KTXwriterScParams"

pattern KTXastcDecodeMode :: Text
pattern KTXastcDecodeMode = "KTXastcDecodeMode"

pattern KTXanimData :: Text
pattern KTXanimData = "KTXanimData"