Arguments.hs

-- | Module      : IPLD.DagCBOR.Decoder.Arguments
--   Description : Provides arguments for the major types in CBOR
--   Copyright   : Zoey McBride (c) 2026
--   License     : AGPL-3.0-or-later
--   Maintainer  : zoeymcbride@mailbox.org
--   Stability   : experimental
module IPLD.DagCBOR.Decoder.Arguments
  ( -- * Type class for resolving argument types.
    Argument (decodeArg),

    -- * Implements Argument for Integer types
    Ints (..),
    intsSizeOf,

    -- * Stores read CBOR integers
    IntData,
    downcastIntData,

    -- * Implements Arguments for special items (Booleans, Floats, etc)
    Simple (..),

    -- * Stores read CBOR simple types
    SimpleData (..),
    simpleSizeOf,

    -- * Implements Argument for Collections (Arrays, Maps, Strings, etc)
    Collection (..),

    -- * Implements Arguments for CID tags.
    Tag (..),

    -- * DecoderMethod utilities
    extractByte,
    extractBytes,
    extractIntData,
    dropBytes,
    removeOctet,

    -- * Extracts major identifiers and major parameters from raw bytes.
    maskMajorID,
    maskMajorArg,
  )
where

import Data.Bits ((.&.), (.>>.))
import Data.Word (Word64, Word8)
import Data.XCodec.BinaryTranscoder (BinaryTranscoder, Octet)
import Data.XCodec.BinaryTranscoder qualified as BXC
import IPLD.DM qualified as DM
import IPLD.DagCBOR.Decoder.Errors

-- | Extracts a single byte from the transcoder data.
{-# INLINEABLE extractByte #-}
extractByte :: (BinaryTranscoder bxc) => DecoderMethod Word8 bxc
extractByte bytes =
  case BXC.uncons bytes of
    Nothing -> Left UnexpectedStop
    Just (byte, rest) -> byte `seq` Right $ Result byte rest

-- | Extracts multiple bytes from a transcoder.
{-# INLINEABLE extractBytes #-}
extractBytes :: (BinaryTranscoder bxc) => Int -> DecoderMethod bxc bxc
extractBytes pos bytes =
  case BXC.splitOffset pos bytes of
    (top, rest)
      | BXC.totalOctets top < pos -> Left UnexpectedStop
      | otherwise -> Right $ Result top rest

-- | Extracts an Integer value given the rule.
{-# INLINEABLE extractIntData #-}
extractIntData :: (BinaryTranscoder bxc) => Ints -> DecoderMethod IntData bxc
extractIntData ints bytes =
  case ints of
    Ints5Bits param -> convIntData param bytes
    _IntsLarger -> do
      Result intdata rest <- extractBytes (intsSizeOf ints) bytes
      convIntData (BXC.unpackValueBE intdata) rest
  where
    -- Converts the value into IntData and strictly evaluates it
    convIntData intdata rest =
      let value = fromIntegral intdata
       in value `seq` Right $ Result value rest

-- | Extracts some number of bytes from the transcoder data.
{-# INLINEABLE dropBytes #-}
dropBytes :: (BinaryTranscoder bxc) => IntData -> DecoderRoutine bxc
dropBytes pos bytes = do
  ipos <- downcastIntData pos
  case BXC.splitOffset ipos bytes of
    (top, rest)
      | BXC.totalOctets top < ipos -> Left UnexpectedStop
      | otherwise -> Right $ Finish rest

-- | Removes some value and only suceeds when it matches its first octet in the
-- transcoder.
{-# INLINEABLE removeOctet #-}
removeOctet :: (BinaryTranscoder bxc) => Octet -> DecoderRoutine bxc
removeOctet value bytes = do
  Result tag rest <- extractByte bytes
  if tag /= value
    then Left UnexpectedValue
    else Right $ Finish rest

-- Extracts the major-type's id from a byte.
{-# INLINE maskMajorID #-}
maskMajorID :: Word8 -> Word8
maskMajorID byte = (byte .&. 0b11100000) .>>. 5

-- Extracts the major-type's param from a byte.
{-# INLINE maskMajorArg #-}
maskMajorArg :: Word8 -> Word8
maskMajorArg byte = byte .&. 0b00011111

-- | Type-class for parsing argument types.
class Argument a where
  -- | Decodes type `a` from parameter id.
  decodeArg :: Word8 -> Okay a

-- | Represents the possible 5-bits following the 3-bit major for an integer
-- value (signed or unsigned). Encodes how to interpret the following bytes or
-- the current argument.
data Ints
  = -- | For values < 24 we can store in the lower 5 bits of the byte
    Ints5Bits Word8
  | -- | For 8-bit values >= 24, we use the next byte following the idenitfier.
    Ints8Bits
  | -- | For 16-bit values we use the next 2 bytes following the identifier.
    Ints16Bits
  | -- | For 32-bit values we use the next 4 bytes following the identifier.
    Ints32Bits
  | -- | For 64-bit values we use the next 8 bytes following the identifier.
    Ints64Bits
  deriving (Show, Eq)

-- | Implements the section from:
-- https://datatracker.ietf.org/doc/html/rfc8949#section-3-2
instance Argument Ints where
  {-# INLINEABLE decodeArg #-}
  decodeArg arg =
    case maskMajorArg arg of
      param
        | param == 27 -> Right Ints64Bits
        | param == 26 -> Right Ints32Bits
        | param == 25 -> Right Ints16Bits
        | param == 24 -> Right Ints8Bits
        | param <= 23 -> Right (Ints5Bits param)
        | otherwise -> Left ReservedParam

-- | Returns the #bytes a `Ints` type occupies after its argument.
{-# INLINE intsSizeOf #-}
intsSizeOf :: Ints -> Int
intsSizeOf ints =
  case ints of
    Ints5Bits _ -> 0
    Ints8Bits -> 1
    Ints16Bits -> 2
    Ints32Bits -> 4
    Ints64Bits -> 8

-- | Type-alias for `Word64` for CBOR integer data.
type IntData = Word64

-- | For converting `IntData` into smaller types such as `Int`.
{-# INLINE downcastIntData #-}
downcastIntData :: forall a. (Integral a, Bounded a) => IntData -> Okay a
downcastIntData intdata
  | intdata > fromIntegral (maxBound :: a) = Left DowncastFailed
  | otherwise =
      -- Convert the intdata and strictly evaluate it
      let int = fromIntegral intdata
       in int `seq` Right int

-- | Represents the possible 5-bits following the 3-bit major for byte strings,
-- text, arrays and mappings.
data Collection
  = -- | Provides the length for some grouping of data within the same format as
    -- integers' arguments.
    CollectionsLength Ints
  | -- | Indefinite length groupings. Unsupported in DAG-CBOR.
    CollectionsIndefinite
  deriving (Show, Eq)

-- | Implements the section from:
-- https://datatracker.ietf.org/doc/html/rfc8949#section-3-3.8
instance Argument Collection where
  {-# INLINEABLE decodeArg #-}
  decodeArg arg =
    case maskMajorArg arg of
      param
        -- All set 5-bits marks grouping to indefinite.
        | param == 31 -> Left Indefinite
        -- Otherwise, interpret the argument as an int value.
        | otherwise -> CollectionsLength <$> decodeArg param

-- | Represents a tag for marking special data. DAG-CBOR only supports tagging
-- for CID data.
data Tag = Tag deriving (Show, Eq)

-- | Implements tags for DAG-CBOR, see:
-- https://ipld.io/specs/codecs/dag-cbor/spec/#strictness
instance Argument Tag where
  {-# INLINEABLE decodeArg #-}
  decodeArg arg =
    case decodeArg (maskMajorArg arg) of
      -- Valid tags expect an 8-bit value
      Right Ints8Bits -> Right Tag
      -- Report the unsupported param
      Right _gt8bits -> Left InvalidTag
      -- Otherwise, pass the error when given
      Left err -> Left err

-- | Represents the possible arguments following a "simple" (here, special)
-- major type. Used to store floats and some familiar JSON primatives.
data Simple
  = -- | Represents true + false.
    SimpleBool Bool
  | -- | Represents JSON style null.
    SimpleNull
  | -- | Represents JSON style undefined.
    SimpleUndefined
  | -- | For 16-bit half floats in the next 2 bytes.
    FloatHalf
  | -- | For 32-bit single floats in the next 4 bytes.
    FloatSingle
  | -- | For 64-bit double floats in the next 8 bytes.
    FloatDouble
  | -- | Marks the end of an indefinite grouping. Unsupported in DAG-CBOR.
    StopCollection
  deriving (Show, Eq)

-- | Implements the section from:
-- https://datatracker.ietf.org/doc/html/rfc8949#section-3.3
-- And the constraints from:
-- https://ipld.io/specs/codecs/dag-cbor/spec/#strictness
instance Argument Simple where
  {-# INLINEABLE decodeArg #-}
  decodeArg arg =
    case maskMajorArg arg of
      param
        | param == 31 -> Left Indefinite
        | param == 27 -> Right FloatDouble
        | param == 26 -> Right FloatSingle
        | param == 25 -> Right FloatHalf
        | param == 23 -> Left NotDefined
        | param == 22 -> Right SimpleNull
        | param == 21 -> Right (SimpleBool True)
        | param == 20 -> Right (SimpleBool False)
        | otherwise -> Left ReservedParam

-- | Returns the #bytes a `Simple` type occupies after its argument.
{-# INLINE simpleSizeOf #-}
simpleSizeOf :: Simple -> Int
simpleSizeOf simple =
  case simple of
    FloatHalf -> 2
    FloatSingle -> 4
    FloatDouble -> 8
    _SimpleOther -> 0

-- | Stores values from Special arguments.
data SimpleData
  = FloatData DM.FloatData
  | BoolData Bool
  | NullData
  deriving (Show, Eq)